llvm-project

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 <functional>
18
#include <list>
19
#include <map>
20
#include <string>
21

22
// The symbols added by this code to various scopes in the program include:
23
//   .b.TYPE.NAME  - Bounds values for an array component
24
//   .c.TYPE       - TYPE(Component) descriptions for TYPE
25
//   .di.TYPE.NAME - Data initialization for a component
26
//   .dp.TYPE.NAME - Data pointer initialization for a component
27
//   .dt.TYPE      - TYPE(DerivedType) description for TYPE
28
//   .kp.TYPE      - KIND type parameter values for TYPE
29
//   .lpk.TYPE     - Integer kinds of LEN type parameter values
30
//   .lv.TYPE.NAME - LEN type parameter values for a component's type
31
//   .n.NAME       - Character representation of a name
32
//   .p.TYPE       - TYPE(ProcPtrComponent) descriptions for TYPE
33
//   .s.TYPE       - TYPE(SpecialBinding) bindings for TYPE
34
//   .v.TYPE       - TYPE(Binding) bindings for TYPE
35

36
namespace Fortran::semantics {
37

38
static int FindLenParameterIndex(
39
    const SymbolVector &parameters, const Symbol &symbol) {
40
  int lenIndex{0};
41
  for (SymbolRef ref : parameters) {
42
    if (&*ref == &symbol) {
43
      return lenIndex;
44
    }
45
    if (ref->get<TypeParamDetails>().attr() == common::TypeParamAttr::Len) {
46
      ++lenIndex;
47
    }
48
  }
49
  DIE("Length type parameter not found in parameter order");
50
  return -1;
51
}
52

53
class RuntimeTableBuilder {
54
public:
55
  RuntimeTableBuilder(SemanticsContext &, RuntimeDerivedTypeTables &);
56
  void DescribeTypes(Scope &scope, bool inSchemata);
57

58
private:
59
  const Symbol *DescribeType(Scope &);
60
  const Symbol &GetSchemaSymbol(const char *) const;
61
  const DeclTypeSpec &GetSchema(const char *) const;
62
  SomeExpr GetEnumValue(const char *) const;
63
  Symbol &CreateObject(const std::string &, const DeclTypeSpec &, Scope &);
64
  // The names of created symbols are saved in and owned by the
65
  // RuntimeDerivedTypeTables instance returned by
66
  // BuildRuntimeDerivedTypeTables() so that references to those names remain
67
  // valid for lowering.
68
  SourceName SaveObjectName(const std::string &);
69
  SomeExpr SaveNameAsPointerTarget(Scope &, const std::string &);
70
  const SymbolVector *GetTypeParameters(const Symbol &);
71
  evaluate::StructureConstructor DescribeComponent(const Symbol &,
72
      const ObjectEntityDetails &, Scope &, Scope &,
73
      const std::string &distinctName, const SymbolVector *parameters);
74
  evaluate::StructureConstructor DescribeComponent(
75
      const Symbol &, const ProcEntityDetails &, Scope &);
76
  bool InitializeDataPointer(evaluate::StructureConstructorValues &,
77
      const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
78
      Scope &dtScope, const std::string &distinctName);
79
  evaluate::StructureConstructor PackageIntValue(
80
      const SomeExpr &genre, std::int64_t = 0) const;
81
  SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const;
82
  std::vector<evaluate::StructureConstructor> DescribeBindings(
83
      const Scope &dtScope, Scope &);
84
  std::map<int, evaluate::StructureConstructor> DescribeSpecialGenerics(
85
      const Scope &dtScope, const Scope &thisScope,
86
      const DerivedTypeSpec *) const;
87
  void DescribeSpecialGeneric(const GenericDetails &,
88
      std::map<int, evaluate::StructureConstructor> &, const Scope &,
89
      const DerivedTypeSpec *) const;
90
  void DescribeSpecialProc(std::map<int, evaluate::StructureConstructor> &,
91
      const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
92
      std::optional<common::DefinedIo>, const Scope *, const DerivedTypeSpec *,
93
      bool isTypeBound) const;
94
  void IncorporateDefinedIoGenericInterfaces(
95
      std::map<int, evaluate::StructureConstructor> &, common::DefinedIo,
96
      const Scope *, const DerivedTypeSpec *);
97

98
  // Instantiated for ParamValue and Bound
99
  template <typename A>
100
  evaluate::StructureConstructor GetValue(
101
      const A &x, const SymbolVector *parameters) {
102
    if (x.isExplicit()) {
103
      return GetValue(x.GetExplicit(), parameters);
104
    } else {
105
      return PackageIntValue(deferredEnum_);
106
    }
107
  }
108

109
  // Specialization for optional<Expr<SomeInteger and SubscriptInteger>>
110
  template <typename T>
111
  evaluate::StructureConstructor GetValue(
112
      const std::optional<evaluate::Expr<T>> &expr,
113
      const SymbolVector *parameters) {
114
    if (auto constValue{evaluate::ToInt64(expr)}) {
115
      return PackageIntValue(explicitEnum_, *constValue);
116
    }
117
    if (expr) {
118
      if (parameters) {
119
        if (const Symbol * lenParam{evaluate::ExtractBareLenParameter(*expr)}) {
120
          return PackageIntValue(
121
              lenParameterEnum_, FindLenParameterIndex(*parameters, *lenParam));
122
        }
123
      }
124
      // TODO: Replace a specification expression requiring actual operations
125
      // with a reference to a new anonymous LEN type parameter whose default
126
      // value captures the expression.  This replacement must take place when
127
      // the type is declared so that the new LEN type parameters appear in
128
      // all instantiations and structure constructors.
129
      context_.Say(location_,
130
          "derived type specification expression '%s' that is neither constant nor a length type parameter"_todo_en_US,
131
          expr->AsFortran());
132
    }
133
    return PackageIntValue(deferredEnum_);
134
  }
135

136
  SemanticsContext &context_;
137
  RuntimeDerivedTypeTables &tables_;
138
  std::map<const Symbol *, SymbolVector> orderedTypeParameters_;
139

140
  const DeclTypeSpec &derivedTypeSchema_; // TYPE(DerivedType)
141
  const DeclTypeSpec &componentSchema_; // TYPE(Component)
142
  const DeclTypeSpec &procPtrSchema_; // TYPE(ProcPtrComponent)
143
  const DeclTypeSpec &valueSchema_; // TYPE(Value)
144
  const DeclTypeSpec &bindingSchema_; // TYPE(Binding)
145
  const DeclTypeSpec &specialSchema_; // TYPE(SpecialBinding)
146
  SomeExpr deferredEnum_; // Value::Genre::Deferred
147
  SomeExpr explicitEnum_; // Value::Genre::Explicit
148
  SomeExpr lenParameterEnum_; // Value::Genre::LenParameter
149
  SomeExpr scalarAssignmentEnum_; // SpecialBinding::Which::ScalarAssignment
150
  SomeExpr
151
      elementalAssignmentEnum_; // SpecialBinding::Which::ElementalAssignment
152
  SomeExpr readFormattedEnum_; // SpecialBinding::Which::ReadFormatted
153
  SomeExpr readUnformattedEnum_; // SpecialBinding::Which::ReadUnformatted
154
  SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted
155
  SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted
156
  SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal
157
  SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal
158
  SomeExpr scalarFinalEnum_; // SpecialBinding::Which::ScalarFinal
159
  parser::CharBlock location_;
160
  std::set<const Scope *> ignoreScopes_;
161
};
162

163
RuntimeTableBuilder::RuntimeTableBuilder(
164
    SemanticsContext &c, RuntimeDerivedTypeTables &t)
165
    : context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")},
166
      componentSchema_{GetSchema("component")},
167
      procPtrSchema_{GetSchema("procptrcomponent")},
168
      valueSchema_{GetSchema("value")},
169
      bindingSchema_{GetSchema(bindingDescCompName)},
170
      specialSchema_{GetSchema("specialbinding")},
171
      deferredEnum_{GetEnumValue("deferred")},
172
      explicitEnum_{GetEnumValue("explicit")},
173
      lenParameterEnum_{GetEnumValue("lenparameter")},
174
      scalarAssignmentEnum_{GetEnumValue("scalarassignment")},
175
      elementalAssignmentEnum_{GetEnumValue("elementalassignment")},
176
      readFormattedEnum_{GetEnumValue("readformatted")},
177
      readUnformattedEnum_{GetEnumValue("readunformatted")},
178
      writeFormattedEnum_{GetEnumValue("writeformatted")},
179
      writeUnformattedEnum_{GetEnumValue("writeunformatted")},
180
      elementalFinalEnum_{GetEnumValue("elementalfinal")},
181
      assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")},
182
      scalarFinalEnum_{GetEnumValue("scalarfinal")} {
183
  ignoreScopes_.insert(tables_.schemata);
184
}
185

186
static void SetReadOnlyCompilerCreatedFlags(Symbol &symbol) {
187
  symbol.set(Symbol::Flag::CompilerCreated);
188
  // Runtime type info symbols may have types that are incompatible with the
189
  // PARAMETER attribute (the main issue is that they may be TARGET, and normal
190
  // Fortran parameters cannot be TARGETs).
191
  if (symbol.has<semantics::ObjectEntityDetails>() ||
192
      symbol.has<semantics::ProcEntityDetails>()) {
193
    symbol.set(Symbol::Flag::ReadOnly);
194
  }
195
}
196

197
// Save an arbitrarily shaped array constant of some derived type
198
// as an initialized data object in a scope.
199
static SomeExpr SaveDerivedPointerTarget(Scope &scope, SourceName name,
200
    std::vector<evaluate::StructureConstructor> &&x,
201
    evaluate::ConstantSubscripts &&shape) {
202
  if (x.empty()) {
203
    return SomeExpr{evaluate::NullPointer{}};
204
  } else {
205
    auto dyType{x.front().GetType()};
206
    const auto &derivedType{dyType.GetDerivedTypeSpec()};
207
    ObjectEntityDetails object;
208
    DeclTypeSpec typeSpec{DeclTypeSpec::TypeDerived, derivedType};
209
    if (const DeclTypeSpec * spec{scope.FindType(typeSpec)}) {
210
      object.set_type(*spec);
211
    } else {
212
      object.set_type(scope.MakeDerivedType(
213
          DeclTypeSpec::TypeDerived, common::Clone(derivedType)));
214
    }
215
    if (!shape.empty()) {
216
      ArraySpec arraySpec;
217
      for (auto n : shape) {
218
        arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{n - 1}));
219
      }
220
      object.set_shape(arraySpec);
221
    }
222
    object.set_init(
223
        evaluate::AsGenericExpr(evaluate::Constant<evaluate::SomeDerived>{
224
            derivedType, std::move(x), std::move(shape)}));
225
    Symbol &symbol{*scope
226
                        .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},
227
                            std::move(object))
228
                        .first->second};
229
    SetReadOnlyCompilerCreatedFlags(symbol);
230
    return evaluate::AsGenericExpr(
231
        evaluate::Designator<evaluate::SomeDerived>{symbol});
232
  }
233
}
234

235
void RuntimeTableBuilder::DescribeTypes(Scope &scope, bool inSchemata) {
236
  inSchemata |= ignoreScopes_.find(&scope) != ignoreScopes_.end();
237
  if (scope.IsDerivedType()) {
238
    if (!inSchemata) { // don't loop trying to describe a schema
239
      DescribeType(scope);
240
    }
241
  } else {
242
    scope.InstantiateDerivedTypes();
243
  }
244
  for (Scope &child : scope.children()) {
245
    DescribeTypes(child, inSchemata);
246
  }
247
}
248

249
// Returns derived type instantiation's parameters in declaration order
250
const SymbolVector *RuntimeTableBuilder::GetTypeParameters(
251
    const Symbol &symbol) {
252
  auto iter{orderedTypeParameters_.find(&symbol)};
253
  if (iter != orderedTypeParameters_.end()) {
254
    return &iter->second;
255
  } else {
256
    return &orderedTypeParameters_
257
                .emplace(&symbol, OrderParameterDeclarations(symbol))
258
                .first->second;
259
  }
260
}
261

262
static Scope &GetContainingNonDerivedScope(Scope &scope) {
263
  Scope *p{&scope};
264
  while (p->IsDerivedType()) {
265
    p = &p->parent();
266
  }
267
  return *p;
268
}
269

270
static const Symbol &GetSchemaField(
271
    const DerivedTypeSpec &derived, const std::string &name) {
272
  const Scope &scope{
273
      DEREF(derived.scope() ? derived.scope() : derived.typeSymbol().scope())};
274
  auto iter{scope.find(SourceName(name))};
275
  CHECK(iter != scope.end());
276
  return *iter->second;
277
}
278

279
static const Symbol &GetSchemaField(
280
    const DeclTypeSpec &derived, const std::string &name) {
281
  return GetSchemaField(DEREF(derived.AsDerived()), name);
282
}
283

284
static evaluate::StructureConstructorValues &AddValue(
285
    evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec,
286
    const std::string &name, SomeExpr &&x) {
287
  values.emplace(GetSchemaField(spec, name), std::move(x));
288
  return values;
289
}
290

291
static evaluate::StructureConstructorValues &AddValue(
292
    evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec,
293
    const std::string &name, const SomeExpr &x) {
294
  values.emplace(GetSchemaField(spec, name), x);
295
  return values;
296
}
297

298
static SomeExpr IntToExpr(std::int64_t n) {
299
  return evaluate::AsGenericExpr(evaluate::ExtentExpr{n});
300
}
301

302
static evaluate::StructureConstructor Structure(
303
    const DeclTypeSpec &spec, evaluate::StructureConstructorValues &&values) {
304
  return {DEREF(spec.AsDerived()), std::move(values)};
305
}
306

307
static SomeExpr StructureExpr(evaluate::StructureConstructor &&x) {
308
  return SomeExpr{evaluate::Expr<evaluate::SomeDerived>{std::move(x)}};
309
}
310

311
static int GetIntegerKind(const Symbol &symbol) {
312
  auto dyType{evaluate::DynamicType::From(symbol)};
313
  CHECK((dyType && dyType->category() == TypeCategory::Integer) ||
314
      symbol.owner().context().HasError(symbol));
315
  return dyType && dyType->category() == TypeCategory::Integer
316
      ? dyType->kind()
317
      : symbol.owner().context().GetDefaultKind(TypeCategory::Integer);
318
}
319

320
// Save a rank-1 array constant of some numeric type as an
321
// initialized data object in a scope.
322
template <typename T>
323
static SomeExpr SaveNumericPointerTarget(
324
    Scope &scope, SourceName name, std::vector<typename T::Scalar> &&x) {
325
  if (x.empty()) {
326
    return SomeExpr{evaluate::NullPointer{}};
327
  } else {
328
    ObjectEntityDetails object;
329
    if (const auto *spec{scope.FindType(
330
            DeclTypeSpec{NumericTypeSpec{T::category, KindExpr{T::kind}}})}) {
331
      object.set_type(*spec);
332
    } else {
333
      object.set_type(scope.MakeNumericType(T::category, KindExpr{T::kind}));
334
    }
335
    auto elements{static_cast<evaluate::ConstantSubscript>(x.size())};
336
    ArraySpec arraySpec;
337
    arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{elements - 1}));
338
    object.set_shape(arraySpec);
339
    object.set_init(evaluate::AsGenericExpr(evaluate::Constant<T>{
340
        std::move(x), evaluate::ConstantSubscripts{elements}}));
341
    Symbol &symbol{*scope
342
                        .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},
343
                            std::move(object))
344
                        .first->second};
345
    SetReadOnlyCompilerCreatedFlags(symbol);
346
    return evaluate::AsGenericExpr(
347
        evaluate::Expr<T>{evaluate::Designator<T>{symbol}});
348
  }
349
}
350

351
static SomeExpr SaveObjectInit(
352
    Scope &scope, SourceName name, const ObjectEntityDetails &object) {
353
  Symbol &symbol{*scope
354
                      .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},
355
                          ObjectEntityDetails{object})
356
                      .first->second};
357
  CHECK(symbol.get<ObjectEntityDetails>().init().has_value());
358
  SetReadOnlyCompilerCreatedFlags(symbol);
359
  return evaluate::AsGenericExpr(
360
      evaluate::Designator<evaluate::SomeDerived>{symbol});
361
}
362

363
template <int KIND> static SomeExpr IntExpr(std::int64_t n) {
364
  return evaluate::AsGenericExpr(
365
      evaluate::Constant<evaluate::Type<TypeCategory::Integer, KIND>>{n});
366
}
367

368
static std::optional<std::string> GetSuffixIfTypeKindParameters(
369
    const DerivedTypeSpec &derivedTypeSpec, const SymbolVector *parameters) {
370
  if (parameters) {
371
    std::optional<std::string> suffix;
372
    for (SymbolRef ref : *parameters) {
373
      const auto &tpd{ref->get<TypeParamDetails>()};
374
      if (tpd.attr() == common::TypeParamAttr::Kind) {
375
        if (const auto *pv{derivedTypeSpec.FindParameter(ref->name())}) {
376
          if (pv->GetExplicit()) {
377
            if (auto instantiatedValue{evaluate::ToInt64(*pv->GetExplicit())}) {
378
              if (suffix.has_value()) {
379
                *suffix += "."s + std::to_string(*instantiatedValue);
380
              } else {
381
                suffix = "."s + std::to_string(*instantiatedValue);
382
              }
383
            }
384
          }
385
        }
386
      }
387
    }
388
    return suffix;
389
  }
390
  return std::nullopt;
391
}
392

393
const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
394
  if (const Symbol * info{dtScope.runtimeDerivedTypeDescription()}) {
395
    return info;
396
  }
397
  const DerivedTypeSpec *derivedTypeSpec{dtScope.derivedTypeSpec()};
398
  if (!derivedTypeSpec && !dtScope.IsDerivedTypeWithKindParameter() &&
399
      dtScope.symbol()) {
400
    // This derived type was declared (obviously, there's a Scope) but never
401
    // used in this compilation (no instantiated DerivedTypeSpec points here).
402
    // Create a DerivedTypeSpec now for it so that ComponentIterator
403
    // will work. This covers the case of a derived type that's declared in
404
    // a module but used only by clients and submodules, enabling the
405
    // run-time "no initialization needed here" flag to work.
406
    DerivedTypeSpec derived{dtScope.symbol()->name(), *dtScope.symbol()};
407
    if (const SymbolVector *
408
        lenParameters{GetTypeParameters(*dtScope.symbol())}) {
409
      // Create dummy deferred values for the length parameters so that the
410
      // DerivedTypeSpec is complete and can be used in helpers.
411
      for (SymbolRef lenParam : *lenParameters) {
412
        (void)lenParam;
413
        derived.AddRawParamValue(
414
            nullptr, ParamValue::Deferred(common::TypeParamAttr::Len));
415
      }
416
      derived.CookParameters(context_.foldingContext());
417
    }
418
    DeclTypeSpec &decl{
419
        dtScope.MakeDerivedType(DeclTypeSpec::TypeDerived, std::move(derived))};
420
    derivedTypeSpec = &decl.derivedTypeSpec();
421
  }
422
  const Symbol *dtSymbol{
423
      derivedTypeSpec ? &derivedTypeSpec->typeSymbol() : dtScope.symbol()};
424
  if (!dtSymbol) {
425
    return nullptr;
426
  }
427
  auto locationRestorer{common::ScopedSet(location_, dtSymbol->name())};
428
  // Check for an existing description that can be imported from a USE'd module
429
  std::string typeName{dtSymbol->name().ToString()};
430
  if (typeName.empty() ||
431
      (typeName.front() == '.' && !context_.IsTempName(typeName))) {
432
    return nullptr;
433
  }
434
  bool isPDTDefinitionWithKindParameters{
435
      !derivedTypeSpec && dtScope.IsDerivedTypeWithKindParameter()};
436
  bool isPDTInstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
437
  const SymbolVector *parameters{GetTypeParameters(*dtSymbol)};
438
  std::string distinctName{typeName};
439
  if (isPDTInstantiation) {
440
    // Only create new type descriptions for different kind parameter values.
441
    // Type with different length parameters/same kind parameters can all
442
    // share the same type description available in the current scope.
443
    if (auto suffix{
444
            GetSuffixIfTypeKindParameters(*derivedTypeSpec, parameters)}) {
445
      distinctName += *suffix;
446
    }
447
  } else if (isPDTDefinitionWithKindParameters) {
448
    return nullptr;
449
  }
450
  std::string dtDescName{".dt."s + distinctName};
451
  Scope *dtSymbolScope{const_cast<Scope *>(dtSymbol->scope())};
452
  Scope &scope{
453
      GetContainingNonDerivedScope(dtSymbolScope ? *dtSymbolScope : dtScope)};
454
  if (const auto it{scope.find(SourceName{dtDescName})}; it != scope.end()) {
455
    dtScope.set_runtimeDerivedTypeDescription(*it->second);
456
    return &*it->second;
457
  }
458

459
  // Create a new description object before populating it so that mutual
460
  // references will work as pointer targets.
461
  Symbol &dtObject{CreateObject(dtDescName, derivedTypeSchema_, scope)};
462
  dtScope.set_runtimeDerivedTypeDescription(dtObject);
463
  evaluate::StructureConstructorValues dtValues;
464
  AddValue(dtValues, derivedTypeSchema_, "name"s,
465
      SaveNameAsPointerTarget(scope, typeName));
466
  if (!isPDTDefinitionWithKindParameters) {
467
    auto sizeInBytes{static_cast<common::ConstantSubscript>(dtScope.size())};
468
    if (auto alignment{dtScope.alignment().value_or(0)}) {
469
      sizeInBytes += alignment - 1;
470
      sizeInBytes /= alignment;
471
      sizeInBytes *= alignment;
472
    }
473
    AddValue(
474
        dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes));
475
  }
476
  if (const Symbol *
477
      uninstDescObject{isPDTInstantiation
478
              ? DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))
479
              : nullptr}) {
480
    AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
481
        evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
482
            evaluate::Designator<evaluate::SomeDerived>{
483
                DEREF(uninstDescObject)}}));
484
  } else {
485
    AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
486
        SomeExpr{evaluate::NullPointer{}});
487
  }
488
  using Int8 = evaluate::Type<TypeCategory::Integer, 8>;
489
  using Int1 = evaluate::Type<TypeCategory::Integer, 1>;
490
  std::vector<Int8::Scalar> kinds;
491
  std::vector<Int1::Scalar> lenKinds;
492
  if (parameters) {
493
    // Package the derived type's parameters in declaration order for
494
    // each category of parameter.  KIND= type parameters are described
495
    // by their instantiated (or default) values, while LEN= type
496
    // parameters are described by their INTEGER kinds.
497
    for (SymbolRef ref : *parameters) {
498
      if (const auto *inst{dtScope.FindComponent(ref->name())}) {
499
        const auto &tpd{inst->get<TypeParamDetails>()};
500
        if (tpd.attr() == common::TypeParamAttr::Kind) {
501
          auto value{evaluate::ToInt64(tpd.init()).value_or(0)};
502
          if (derivedTypeSpec) {
503
            if (const auto *pv{derivedTypeSpec->FindParameter(inst->name())}) {
504
              if (pv->GetExplicit()) {
505
                if (auto instantiatedValue{
506
                        evaluate::ToInt64(*pv->GetExplicit())}) {
507
                  value = *instantiatedValue;
508
                }
509
              }
510
            }
511
          }
512
          kinds.emplace_back(value);
513
        } else { // LEN= parameter
514
          lenKinds.emplace_back(GetIntegerKind(*inst));
515
        }
516
      }
517
    }
518
  }
519
  AddValue(dtValues, derivedTypeSchema_, "kindparameter"s,
520
      SaveNumericPointerTarget<Int8>(
521
          scope, SaveObjectName(".kp."s + distinctName), std::move(kinds)));
522
  AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s,
523
      SaveNumericPointerTarget<Int1>(
524
          scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds)));
525
  // Traverse the components of the derived type
526
  if (!isPDTDefinitionWithKindParameters) {
527
    std::vector<const Symbol *> dataComponentSymbols;
528
    std::vector<evaluate::StructureConstructor> procPtrComponents;
529
    for (const auto &pair : dtScope) {
530
      const Symbol &symbol{*pair.second};
531
      auto locationRestorer{common::ScopedSet(location_, symbol.name())};
532
      common::visit(
533
          common::visitors{
534
              [&](const TypeParamDetails &) {
535
                // already handled above in declaration order
536
              },
537
              [&](const ObjectEntityDetails &) {
538
                dataComponentSymbols.push_back(&symbol);
539
              },
540
              [&](const ProcEntityDetails &proc) {
541
                if (IsProcedurePointer(symbol)) {
542
                  procPtrComponents.emplace_back(
543
                      DescribeComponent(symbol, proc, scope));
544
                }
545
              },
546
              [&](const ProcBindingDetails &) { // handled in a later pass
547
              },
548
              [&](const GenericDetails &) { // ditto
549
              },
550
              [&](const auto &) {
551
                common::die(
552
                    "unexpected details on symbol '%s' in derived type scope",
553
                    symbol.name().ToString().c_str());
554
              },
555
          },
556
          symbol.details());
557
    }
558
    // Sort the data component symbols by offset before emitting them, placing
559
    // the parent component first if any.
560
    std::sort(dataComponentSymbols.begin(), dataComponentSymbols.end(),
561
        [](const Symbol *x, const Symbol *y) {
562
          return x->test(Symbol::Flag::ParentComp) || x->offset() < y->offset();
563
        });
564
    std::vector<evaluate::StructureConstructor> dataComponents;
565
    for (const Symbol *symbol : dataComponentSymbols) {
566
      auto locationRestorer{common::ScopedSet(location_, symbol->name())};
567
      dataComponents.emplace_back(
568
          DescribeComponent(*symbol, symbol->get<ObjectEntityDetails>(), scope,
569
              dtScope, distinctName, parameters));
570
    }
571
    AddValue(dtValues, derivedTypeSchema_, "component"s,
572
        SaveDerivedPointerTarget(scope, SaveObjectName(".c."s + distinctName),
573
            std::move(dataComponents),
574
            evaluate::ConstantSubscripts{
575
                static_cast<evaluate::ConstantSubscript>(
576
                    dataComponents.size())}));
577
    AddValue(dtValues, derivedTypeSchema_, "procptr"s,
578
        SaveDerivedPointerTarget(scope, SaveObjectName(".p."s + distinctName),
579
            std::move(procPtrComponents),
580
            evaluate::ConstantSubscripts{
581
                static_cast<evaluate::ConstantSubscript>(
582
                    procPtrComponents.size())}));
583
    // Compile the "vtable" of type-bound procedure bindings
584
    std::uint32_t specialBitSet{0};
585
    if (!dtSymbol->attrs().test(Attr::ABSTRACT)) {
586
      std::vector<evaluate::StructureConstructor> bindings{
587
          DescribeBindings(dtScope, scope)};
588
      AddValue(dtValues, derivedTypeSchema_, bindingDescCompName,
589
          SaveDerivedPointerTarget(scope, SaveObjectName(".v."s + distinctName),
590
              std::move(bindings),
591
              evaluate::ConstantSubscripts{
592
                  static_cast<evaluate::ConstantSubscript>(bindings.size())}));
593
      // Describe "special" bindings to defined assignments, FINAL subroutines,
594
      // and defined derived type I/O subroutines.  Defined assignments and I/O
595
      // subroutines override any parent bindings, but FINAL subroutines do not
596
      // (the runtime will call all of them).
597
      std::map<int, evaluate::StructureConstructor> specials{
598
          DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)};
599
      if (derivedTypeSpec) {
600
        for (auto &ref : FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) {
601
          DescribeSpecialProc(specials, *ref, /*isAssignment-*/ false,
602
              /*isFinal=*/true, std::nullopt, nullptr, derivedTypeSpec,
603
              /*isTypeBound=*/true);
604
        }
605
        IncorporateDefinedIoGenericInterfaces(specials,
606
            common::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
607
        IncorporateDefinedIoGenericInterfaces(specials,
608
            common::DefinedIo::ReadUnformatted, &scope, derivedTypeSpec);
609
        IncorporateDefinedIoGenericInterfaces(specials,
610
            common::DefinedIo::WriteFormatted, &scope, derivedTypeSpec);
611
        IncorporateDefinedIoGenericInterfaces(specials,
612
            common::DefinedIo::WriteUnformatted, &scope, derivedTypeSpec);
613
      }
614
      // Pack the special procedure bindings in ascending order of their "which"
615
      // code values, and compile a little-endian bit-set of those codes for
616
      // use in O(1) look-up at run time.
617
      std::vector<evaluate::StructureConstructor> sortedSpecials;
618
      for (auto &pair : specials) {
619
        auto bit{std::uint32_t{1} << pair.first};
620
        CHECK(!(specialBitSet & bit));
621
        specialBitSet |= bit;
622
        sortedSpecials.emplace_back(std::move(pair.second));
623
      }
624
      AddValue(dtValues, derivedTypeSchema_, "special"s,
625
          SaveDerivedPointerTarget(scope, SaveObjectName(".s."s + distinctName),
626
              std::move(sortedSpecials),
627
              evaluate::ConstantSubscripts{
628
                  static_cast<evaluate::ConstantSubscript>(specials.size())}));
629
    }
630
    AddValue(dtValues, derivedTypeSchema_, "specialbitset"s,
631
        IntExpr<4>(specialBitSet));
632
    // Note the presence/absence of a parent component
633
    AddValue(dtValues, derivedTypeSchema_, "hasparent"s,
634
        IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr));
635
    // To avoid wasting run time attempting to initialize derived type
636
    // instances without any initialized components, analyze the type
637
    // and set a flag if there's nothing to do for it at run time.
638
    AddValue(dtValues, derivedTypeSchema_, "noinitializationneeded"s,
639
        IntExpr<1>(derivedTypeSpec &&
640
            !derivedTypeSpec->HasDefaultInitialization(false, false)));
641
    // Similarly, a flag to short-circuit destruction when not needed.
642
    AddValue(dtValues, derivedTypeSchema_, "nodestructionneeded"s,
643
        IntExpr<1>(derivedTypeSpec && !derivedTypeSpec->HasDestruction()));
644
    // Similarly, a flag to short-circuit finalization when not needed.
645
    AddValue(dtValues, derivedTypeSchema_, "nofinalizationneeded"s,
646
        IntExpr<1>(
647
            derivedTypeSpec && !MayRequireFinalization(*derivedTypeSpec)));
648
  }
649
  dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{
650
      StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});
651
  return &dtObject;
652
}
653

654
static const Symbol &GetSymbol(const Scope &schemata, SourceName name) {
655
  auto iter{schemata.find(name)};
656
  CHECK(iter != schemata.end());
657
  const Symbol &symbol{*iter->second};
658
  return symbol;
659
}
660

661
const Symbol &RuntimeTableBuilder::GetSchemaSymbol(const char *name) const {
662
  return GetSymbol(
663
      DEREF(tables_.schemata), SourceName{name, std::strlen(name)});
664
}
665

666
const DeclTypeSpec &RuntimeTableBuilder::GetSchema(
667
    const char *schemaName) const {
668
  Scope &schemata{DEREF(tables_.schemata)};
669
  SourceName name{schemaName, std::strlen(schemaName)};
670
  const Symbol &symbol{GetSymbol(schemata, name)};
671
  CHECK(symbol.has<DerivedTypeDetails>());
672
  CHECK(symbol.scope());
673
  CHECK(symbol.scope()->IsDerivedType());
674
  const DeclTypeSpec *spec{nullptr};
675
  if (symbol.scope()->derivedTypeSpec()) {
676
    DeclTypeSpec typeSpec{
677
        DeclTypeSpec::TypeDerived, *symbol.scope()->derivedTypeSpec()};
678
    spec = schemata.FindType(typeSpec);
679
  }
680
  if (!spec) {
681
    DeclTypeSpec typeSpec{
682
        DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}};
683
    spec = schemata.FindType(typeSpec);
684
  }
685
  if (!spec) {
686
    spec = &schemata.MakeDerivedType(
687
        DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol});
688
  }
689
  CHECK(spec->AsDerived());
690
  return *spec;
691
}
692

693
SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const {
694
  const Symbol &symbol{GetSchemaSymbol(name)};
695
  auto value{evaluate::ToInt64(symbol.get<ObjectEntityDetails>().init())};
696
  CHECK(value.has_value());
697
  return IntExpr<1>(*value);
698
}
699

700
Symbol &RuntimeTableBuilder::CreateObject(
701
    const std::string &name, const DeclTypeSpec &type, Scope &scope) {
702
  ObjectEntityDetails object;
703
  object.set_type(type);
704
  auto pair{scope.try_emplace(SaveObjectName(name),
705
      Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))};
706
  CHECK(pair.second);
707
  Symbol &result{*pair.first->second};
708
  SetReadOnlyCompilerCreatedFlags(result);
709
  return result;
710
}
711

712
SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) {
713
  return *tables_.names.insert(name).first;
714
}
715

716
SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(
717
    Scope &scope, const std::string &name) {
718
  CHECK(!name.empty());
719
  CHECK(name.front() != '.' || context_.IsTempName(name));
720
  ObjectEntityDetails object;
721
  auto len{static_cast<common::ConstantSubscript>(name.size())};
722
  if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{
723
          ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) {
724
    object.set_type(*spec);
725
  } else {
726
    object.set_type(scope.MakeCharacterType(
727
        ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}));
728
  }
729
  using evaluate::Ascii;
730
  using AsciiExpr = evaluate::Expr<Ascii>;
731
  object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));
732
  Symbol &symbol{*scope
733
                      .try_emplace(SaveObjectName(".n."s + name),
734
                          Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
735
                      .first->second};
736
  SetReadOnlyCompilerCreatedFlags(symbol);
737
  return evaluate::AsGenericExpr(
738
      AsciiExpr{evaluate::Designator<Ascii>{symbol}});
739
}
740

741
evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
742
    const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
743
    Scope &dtScope, const std::string &distinctName,
744
    const SymbolVector *parameters) {
745
  evaluate::StructureConstructorValues values;
746
  auto &foldingContext{context_.foldingContext()};
747
  auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
748
      symbol, foldingContext)};
749
  CHECK(typeAndShape.has_value());
750
  auto dyType{typeAndShape->type()};
751
  int rank{typeAndShape->Rank()};
752
  AddValue(values, componentSchema_, "name"s,
753
      SaveNameAsPointerTarget(scope, symbol.name().ToString()));
754
  AddValue(values, componentSchema_, "category"s,
755
      IntExpr<1>(static_cast<int>(dyType.category())));
756
  if (dyType.IsUnlimitedPolymorphic() ||
757
      dyType.category() == TypeCategory::Derived) {
758
    AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
759
  } else {
760
    AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
761
  }
762
  AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
763
  // CHARACTER length
764
  auto len{typeAndShape->LEN()};
765
  if (const semantics::DerivedTypeSpec *
766
      pdtInstance{dtScope.derivedTypeSpec()}) {
767
    auto restorer{foldingContext.WithPDTInstance(*pdtInstance)};
768
    len = Fold(foldingContext, std::move(len));
769
  }
770
  if (dyType.category() == TypeCategory::Character && len) {
771
    // Ignore IDIM(x) (represented as MAX(0, x))
772
    if (const auto *clamped{evaluate::UnwrapExpr<
773
            evaluate::Extremum<evaluate::SubscriptInteger>>(*len)}) {
774
      if (clamped->ordering == evaluate::Ordering::Greater &&
775
          clamped->left() == evaluate::Expr<evaluate::SubscriptInteger>{0}) {
776
        len = common::Clone(clamped->right());
777
      }
778
    }
779
    AddValue(values, componentSchema_, "characterlen"s,
780
        evaluate::AsGenericExpr(GetValue(len, parameters)));
781
  } else {
782
    AddValue(values, componentSchema_, "characterlen"s,
783
        PackageIntValueExpr(deferredEnum_));
784
  }
785
  // Describe component's derived type
786
  std::vector<evaluate::StructureConstructor> lenParams;
787
  if (dyType.category() == TypeCategory::Derived &&
788
      !dyType.IsUnlimitedPolymorphic()) {
789
    const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};
790
    Scope *derivedScope{const_cast<Scope *>(
791
        spec.scope() ? spec.scope() : spec.typeSymbol().scope())};
792
    if (const Symbol * derivedDescription{DescribeType(DEREF(derivedScope))}) {
793
      AddValue(values, componentSchema_, "derived"s,
794
          evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
795
              evaluate::Designator<evaluate::SomeDerived>{
796
                  DEREF(derivedDescription)}}));
797
      // Package values of LEN parameters, if any
798
      if (const SymbolVector *
799
          specParams{GetTypeParameters(spec.typeSymbol())}) {
800
        for (SymbolRef ref : *specParams) {
801
          const auto &tpd{ref->get<TypeParamDetails>()};
802
          if (tpd.attr() == common::TypeParamAttr::Len) {
803
            if (const ParamValue *
804
                paramValue{spec.FindParameter(ref->name())}) {
805
              lenParams.emplace_back(GetValue(*paramValue, parameters));
806
            } else {
807
              lenParams.emplace_back(GetValue(tpd.init(), parameters));
808
            }
809
          }
810
        }
811
      }
812
    }
813
  } else {
814
    // Subtle: a category of Derived with a null derived type pointer
815
    // signifies CLASS(*)
816
    AddValue(values, componentSchema_, "derived"s,
817
        SomeExpr{evaluate::NullPointer{}});
818
  }
819
  // LEN type parameter values for the component's type
820
  if (!lenParams.empty()) {
821
    AddValue(values, componentSchema_, "lenvalue"s,
822
        SaveDerivedPointerTarget(scope,
823
            SaveObjectName(
824
                ".lv."s + distinctName + "."s + symbol.name().ToString()),
825
            std::move(lenParams),
826
            evaluate::ConstantSubscripts{
827
                static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
828
  } else {
829
    AddValue(values, componentSchema_, "lenvalue"s,
830
        SomeExpr{evaluate::NullPointer{}});
831
  }
832
  // Shape information
833
  AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
834
  if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
835
    std::vector<evaluate::StructureConstructor> bounds;
836
    evaluate::NamedEntity entity{symbol};
837
    for (int j{0}; j < rank; ++j) {
838
      bounds.emplace_back(
839
          GetValue(std::make_optional(
840
                       evaluate::GetRawLowerBound(foldingContext, entity, j)),
841
              parameters));
842
      bounds.emplace_back(GetValue(
843
          evaluate::GetRawUpperBound(foldingContext, entity, j), parameters));
844
    }
845
    AddValue(values, componentSchema_, "bounds"s,
846
        SaveDerivedPointerTarget(scope,
847
            SaveObjectName(
848
                ".b."s + distinctName + "."s + symbol.name().ToString()),
849
            std::move(bounds), evaluate::ConstantSubscripts{2, rank}));
850
  } else {
851
    AddValue(
852
        values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});
853
  }
854
  // Default component initialization
855
  bool hasDataInit{false};
856
  if (IsAllocatable(symbol)) {
857
    AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
858
  } else if (IsPointer(symbol)) {
859
    AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
860
    hasDataInit = InitializeDataPointer(
861
        values, symbol, object, scope, dtScope, distinctName);
862
  } else if (IsAutomatic(symbol)) {
863
    AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));
864
  } else {
865
    AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));
866
    hasDataInit = object.init().has_value();
867
    if (hasDataInit) {
868
      AddValue(values, componentSchema_, "initialization"s,
869
          SaveObjectInit(scope,
870
              SaveObjectName(
871
                  ".di."s + distinctName + "."s + symbol.name().ToString()),
872
              object));
873
    }
874
  }
875
  if (!hasDataInit) {
876
    AddValue(values, componentSchema_, "initialization"s,
877
        SomeExpr{evaluate::NullPointer{}});
878
  }
879
  return {DEREF(componentSchema_.AsDerived()), std::move(values)};
880
}
881

882
evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
883
    const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {
884
  evaluate::StructureConstructorValues values;
885
  AddValue(values, procPtrSchema_, "name"s,
886
      SaveNameAsPointerTarget(scope, symbol.name().ToString()));
887
  AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
888
  if (auto init{proc.init()}; init && *init) {
889
    AddValue(values, procPtrSchema_, "initialization"s,
890
        SomeExpr{evaluate::ProcedureDesignator{**init}});
891
  } else {
892
    AddValue(values, procPtrSchema_, "initialization"s,
893
        SomeExpr{evaluate::NullPointer{}});
894
  }
895
  return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};
896
}
897

898
// Create a static pointer object with the same initialization
899
// from whence the runtime can memcpy() the data pointer
900
// component initialization.
901
// Creates and interconnects the symbols, scopes, and types for
902
//   TYPE :: ptrDt
903
//     type, POINTER :: name
904
//   END TYPE
905
//   TYPE(ptrDt), TARGET, SAVE :: ptrInit = ptrDt(designator)
906
// and then initializes the original component by setting
907
//   initialization = ptrInit
908
// which takes the address of ptrInit because the type is C_PTR.
909
// This technique of wrapping the data pointer component into
910
// a derived type instance disables any reason for lowering to
911
// attempt to dereference the RHS of an initializer, thereby
912
// allowing the runtime to actually perform the initialization
913
// by means of a simple memcpy() of the wrapped descriptor in
914
// ptrInit to the data pointer component being initialized.
915
bool RuntimeTableBuilder::InitializeDataPointer(
916
    evaluate::StructureConstructorValues &values, const Symbol &symbol,
917
    const ObjectEntityDetails &object, Scope &scope, Scope &dtScope,
918
    const std::string &distinctName) {
919
  if (object.init().has_value()) {
920
    SourceName ptrDtName{SaveObjectName(
921
        ".dp."s + distinctName + "."s + symbol.name().ToString())};
922
    Symbol &ptrDtSym{
923
        *scope.try_emplace(ptrDtName, Attrs{}, UnknownDetails{}).first->second};
924
    SetReadOnlyCompilerCreatedFlags(ptrDtSym);
925
    Scope &ptrDtScope{scope.MakeScope(Scope::Kind::DerivedType, &ptrDtSym)};
926
    ignoreScopes_.insert(&ptrDtScope);
927
    ObjectEntityDetails ptrDtObj;
928
    ptrDtObj.set_type(DEREF(object.type()));
929
    ptrDtObj.set_shape(object.shape());
930
    Symbol &ptrDtComp{*ptrDtScope
931
                           .try_emplace(symbol.name(), Attrs{Attr::POINTER},
932
                               std::move(ptrDtObj))
933
                           .first->second};
934
    DerivedTypeDetails ptrDtDetails;
935
    ptrDtDetails.add_component(ptrDtComp);
936
    ptrDtSym.set_details(std::move(ptrDtDetails));
937
    ptrDtSym.set_scope(&ptrDtScope);
938
    DeclTypeSpec &ptrDtDeclType{
939
        scope.MakeDerivedType(DeclTypeSpec::Category::TypeDerived,
940
            DerivedTypeSpec{ptrDtName, ptrDtSym})};
941
    DerivedTypeSpec &ptrDtDerived{DEREF(ptrDtDeclType.AsDerived())};
942
    ptrDtDerived.set_scope(ptrDtScope);
943
    ptrDtDerived.CookParameters(context_.foldingContext());
944
    ptrDtDerived.Instantiate(scope);
945
    ObjectEntityDetails ptrInitObj;
946
    ptrInitObj.set_type(ptrDtDeclType);
947
    evaluate::StructureConstructorValues ptrInitValues;
948
    AddValue(
949
        ptrInitValues, ptrDtDeclType, symbol.name().ToString(), *object.init());
950
    ptrInitObj.set_init(evaluate::AsGenericExpr(
951
        Structure(ptrDtDeclType, std::move(ptrInitValues))));
952
    AddValue(values, componentSchema_, "initialization"s,
953
        SaveObjectInit(scope,
954
            SaveObjectName(
955
                ".di."s + distinctName + "."s + symbol.name().ToString()),
956
            ptrInitObj));
957
    return true;
958
  } else {
959
    return false;
960
  }
961
}
962

963
evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(
964
    const SomeExpr &genre, std::int64_t n) const {
965
  evaluate::StructureConstructorValues xs;
966
  AddValue(xs, valueSchema_, "genre"s, genre);
967
  AddValue(xs, valueSchema_, "value"s, IntToExpr(n));
968
  return Structure(valueSchema_, std::move(xs));
969
}
970

971
SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
972
    const SomeExpr &genre, std::int64_t n) const {
973
  return StructureExpr(PackageIntValue(genre, n));
974
}
975

976
SymbolVector CollectBindings(const Scope &dtScope) {
977
  SymbolVector result;
978
  std::map<SourceName, Symbol *> localBindings;
979
  // Collect local bindings
980
  for (auto pair : dtScope) {
981
    Symbol &symbol{const_cast<Symbol &>(*pair.second)};
982
    if (auto *binding{symbol.detailsIf<ProcBindingDetails>()}) {
983
      localBindings.emplace(symbol.name(), &symbol);
984
      binding->set_numPrivatesNotOverridden(0);
985
    }
986
  }
987
  if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
988
    result = CollectBindings(*parentScope);
989
    // Apply overrides from the local bindings of the extended type
990
    for (auto iter{result.begin()}; iter != result.end(); ++iter) {
991
      const Symbol &symbol{**iter};
992
      auto overriderIter{localBindings.find(symbol.name())};
993
      if (overriderIter != localBindings.end()) {
994
        Symbol &overrider{*overriderIter->second};
995
        if (symbol.attrs().test(Attr::PRIVATE) &&
996
            FindModuleContaining(symbol.owner()) !=
997
                FindModuleContaining(dtScope)) {
998
          // Don't override inaccessible PRIVATE bindings
999
          auto &binding{overrider.get<ProcBindingDetails>()};
1000
          binding.set_numPrivatesNotOverridden(
1001
              binding.numPrivatesNotOverridden() + 1);
1002
        } else {
1003
          *iter = overrider;
1004
          localBindings.erase(overriderIter);
1005
        }
1006
      }
1007
    }
1008
  }
1009
  // Add remaining (non-overriding) local bindings in name order to the result
1010
  for (auto pair : localBindings) {
1011
    result.push_back(*pair.second);
1012
  }
1013
  return result;
1014
}
1015

1016
std::vector<evaluate::StructureConstructor>
1017
RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) {
1018
  std::vector<evaluate::StructureConstructor> result;
1019
  for (const SymbolRef &ref : CollectBindings(dtScope)) {
1020
    evaluate::StructureConstructorValues values;
1021
    AddValue(values, bindingSchema_, procCompName,
1022
        SomeExpr{evaluate::ProcedureDesignator{
1023
            ref.get().get<ProcBindingDetails>().symbol()}});
1024
    AddValue(values, bindingSchema_, "name"s,
1025
        SaveNameAsPointerTarget(scope, ref.get().name().ToString()));
1026
    result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
1027
  }
1028
  return result;
1029
}
1030

1031
std::map<int, evaluate::StructureConstructor>
1032
RuntimeTableBuilder::DescribeSpecialGenerics(const Scope &dtScope,
1033
    const Scope &thisScope, const DerivedTypeSpec *derivedTypeSpec) const {
1034
  std::map<int, evaluate::StructureConstructor> specials;
1035
  if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
1036
    specials =
1037
        DescribeSpecialGenerics(*parentScope, thisScope, derivedTypeSpec);
1038
  }
1039
  for (auto pair : dtScope) {
1040
    const Symbol &symbol{*pair.second};
1041
    if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
1042
      DescribeSpecialGeneric(*generic, specials, thisScope, derivedTypeSpec);
1043
    }
1044
  }
1045
  return specials;
1046
}
1047

1048
void RuntimeTableBuilder::DescribeSpecialGeneric(const GenericDetails &generic,
1049
    std::map<int, evaluate::StructureConstructor> &specials,
1050
    const Scope &dtScope, const DerivedTypeSpec *derivedTypeSpec) const {
1051
  common::visit(
1052
      common::visitors{
1053
          [&](const GenericKind::OtherKind &k) {
1054
            if (k == GenericKind::OtherKind::Assignment) {
1055
              for (auto ref : generic.specificProcs()) {
1056
                DescribeSpecialProc(specials, *ref, /*isAssignment=*/true,
1057
                    /*isFinal=*/false, std::nullopt, &dtScope, derivedTypeSpec,
1058
                    /*isTypeBound=*/true);
1059
              }
1060
            }
1061
          },
1062
          [&](const common::DefinedIo &io) {
1063
            switch (io) {
1064
            case common::DefinedIo::ReadFormatted:
1065
            case common::DefinedIo::ReadUnformatted:
1066
            case common::DefinedIo::WriteFormatted:
1067
            case common::DefinedIo::WriteUnformatted:
1068
              for (auto ref : generic.specificProcs()) {
1069
                DescribeSpecialProc(specials, *ref, /*isAssignment=*/false,
1070
                    /*isFinal=*/false, io, &dtScope, derivedTypeSpec,
1071
                    /*isTypeBound=*/true);
1072
              }
1073
              break;
1074
            }
1075
          },
1076
          [](const auto &) {},
1077
      },
1078
      generic.kind().u);
1079
}
1080

1081
void RuntimeTableBuilder::DescribeSpecialProc(
1082
    std::map<int, evaluate::StructureConstructor> &specials,
1083
    const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
1084
    std::optional<common::DefinedIo> io, const Scope *dtScope,
1085
    const DerivedTypeSpec *derivedTypeSpec, bool isTypeBound) const {
1086
  const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
1087
  if (binding && dtScope) { // use most recent override
1088
    binding = &DEREF(dtScope->FindComponent(specificOrBinding.name()))
1089
                   .get<ProcBindingDetails>();
1090
  }
1091
  const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
1092
  if (auto proc{evaluate::characteristics::Procedure::Characterize(
1093
          specific, context_.foldingContext())}) {
1094
    std::uint8_t isArgDescriptorSet{0};
1095
    std::uint8_t isArgContiguousSet{0};
1096
    int argThatMightBeDescriptor{0};
1097
    MaybeExpr which;
1098
    if (isAssignment) {
1099
      // Only type-bound asst's with the same type on both dummy arguments
1100
      // are germane to the runtime, which needs only these to implement
1101
      // component assignment as part of intrinsic assignment.
1102
      // Non-type-bound generic INTERFACEs and assignments from distinct
1103
      // types must not be used for component intrinsic assignment.
1104
      CHECK(proc->dummyArguments.size() == 2);
1105
      const auto t1{
1106
          DEREF(std::get_if<evaluate::characteristics::DummyDataObject>(
1107
                    &proc->dummyArguments[0].u))
1108
              .type.type()};
1109
      const auto t2{
1110
          DEREF(std::get_if<evaluate::characteristics::DummyDataObject>(
1111
                    &proc->dummyArguments[1].u))
1112
              .type.type()};
1113
      if (!binding || t1.category() != TypeCategory::Derived ||
1114
          t2.category() != TypeCategory::Derived ||
1115
          t1.IsUnlimitedPolymorphic() || t2.IsUnlimitedPolymorphic() ||
1116
          t1.GetDerivedTypeSpec() != t2.GetDerivedTypeSpec()) {
1117
        return;
1118
      }
1119
      which = proc->IsElemental() ? elementalAssignmentEnum_
1120
                                  : scalarAssignmentEnum_;
1121
      if (binding && binding->passName() &&
1122
          *binding->passName() == proc->dummyArguments[1].name) {
1123
        argThatMightBeDescriptor = 1;
1124
        isArgDescriptorSet |= 2;
1125
      } else {
1126
        argThatMightBeDescriptor = 2; // the non-passed-object argument
1127
        isArgDescriptorSet |= 1;
1128
      }
1129
    } else if (isFinal) {
1130
      CHECK(binding == nullptr); // FINALs are not bindings
1131
      CHECK(proc->dummyArguments.size() == 1);
1132
      if (proc->IsElemental()) {
1133
        which = elementalFinalEnum_;
1134
      } else {
1135
        const auto &dummyData{
1136
            std::get<evaluate::characteristics::DummyDataObject>(
1137
                proc->dummyArguments.at(0).u)};
1138
        const auto &typeAndShape{dummyData.type};
1139
        if (typeAndShape.attrs().test(
1140
                evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
1141
          which = assumedRankFinalEnum_;
1142
          isArgDescriptorSet |= 1;
1143
        } else {
1144
          which = scalarFinalEnum_;
1145
          if (int rank{typeAndShape.Rank()}; rank > 0) {
1146
            which = IntExpr<1>(ToInt64(which).value() + rank);
1147
            if (dummyData.IsPassedByDescriptor(proc->IsBindC())) {
1148
              argThatMightBeDescriptor = 1;
1149
            }
1150
            if (!typeAndShape.attrs().test(evaluate::characteristics::
1151
                        TypeAndShape::Attr::AssumedShape) ||
1152
                dummyData.attrs.test(evaluate::characteristics::
1153
                        DummyDataObject::Attr::Contiguous)) {
1154
              isArgContiguousSet |= 1;
1155
            }
1156
          }
1157
        }
1158
      }
1159
    } else { // defined derived type I/O
1160
      CHECK(proc->dummyArguments.size() >= 4);
1161
      const auto *ddo{std::get_if<evaluate::characteristics::DummyDataObject>(
1162
          &proc->dummyArguments[0].u)};
1163
      if (!ddo) {
1164
        return;
1165
      }
1166
      if (derivedTypeSpec &&
1167
          !ddo->type.type().IsTkCompatibleWith(
1168
              evaluate::DynamicType{*derivedTypeSpec})) {
1169
        // Defined I/O specific procedure is not for this derived type.
1170
        return;
1171
      }
1172
      if (ddo->type.type().IsPolymorphic()) {
1173
        isArgDescriptorSet |= 1;
1174
      }
1175
      switch (io.value()) {
1176
      case common::DefinedIo::ReadFormatted:
1177
        which = readFormattedEnum_;
1178
        break;
1179
      case common::DefinedIo::ReadUnformatted:
1180
        which = readUnformattedEnum_;
1181
        break;
1182
      case common::DefinedIo::WriteFormatted:
1183
        which = writeFormattedEnum_;
1184
        break;
1185
      case common::DefinedIo::WriteUnformatted:
1186
        which = writeUnformattedEnum_;
1187
        break;
1188
      }
1189
    }
1190
    if (argThatMightBeDescriptor != 0) {
1191
      if (const auto *dummyData{
1192
              std::get_if<evaluate::characteristics::DummyDataObject>(
1193
                  &proc->dummyArguments.at(argThatMightBeDescriptor - 1).u)}) {
1194
        if (dummyData->IsPassedByDescriptor(proc->IsBindC())) {
1195
          isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
1196
        }
1197
      }
1198
    }
1199
    evaluate::StructureConstructorValues values;
1200
    auto index{evaluate::ToInt64(which)};
1201
    CHECK(index.has_value());
1202
    AddValue(
1203
        values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
1204
    AddValue(values, specialSchema_, "isargdescriptorset"s,
1205
        IntExpr<1>(isArgDescriptorSet));
1206
    AddValue(values, specialSchema_, "istypebound"s,
1207
        IntExpr<1>(isTypeBound ? 1 : 0));
1208
    AddValue(values, specialSchema_, "isargcontiguousset"s,
1209
        IntExpr<1>(isArgContiguousSet));
1210
    AddValue(values, specialSchema_, procCompName,
1211
        SomeExpr{evaluate::ProcedureDesignator{specific}});
1212
    // index might already be present in the case of an override
1213
    specials.emplace(*index,
1214
        evaluate::StructureConstructor{
1215
            DEREF(specialSchema_.AsDerived()), std::move(values)});
1216
  }
1217
}
1218

1219
void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
1220
    std::map<int, evaluate::StructureConstructor> &specials,
1221
    common::DefinedIo definedIo, const Scope *scope,
1222
    const DerivedTypeSpec *derivedTypeSpec) {
1223
  SourceName name{GenericKind::AsFortran(definedIo)};
1224
  for (; !scope->IsGlobal(); scope = &scope->parent()) {
1225
    if (auto asst{scope->find(name)}; asst != scope->end()) {
1226
      const Symbol &generic{asst->second->GetUltimate()};
1227
      const auto &genericDetails{generic.get<GenericDetails>()};
1228
      CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));
1229
      CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == definedIo);
1230
      for (auto ref : genericDetails.specificProcs()) {
1231
        DescribeSpecialProc(specials, *ref, false, false, definedIo, nullptr,
1232
            derivedTypeSpec, false);
1233
      }
1234
    }
1235
  }
1236
}
1237

1238
RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
1239
    SemanticsContext &context) {
1240
  RuntimeDerivedTypeTables result;
1241
  // Do not attempt to read __fortran_type_info.mod when compiling
1242
  // the module on which it depends.
1243
  const auto &allSources{context.allCookedSources().allSources()};
1244
  if (auto firstProv{allSources.GetFirstFileProvenance()}) {
1245
    if (const auto *srcFile{allSources.GetSourceFile(firstProv->start())}) {
1246
      if (srcFile->path().find("__fortran_builtins.f90") != std::string::npos) {
1247
        return result;
1248
      }
1249
    }
1250
  }
1251
  result.schemata = context.GetBuiltinModule(typeInfoBuiltinModule);
1252
  if (result.schemata) {
1253
    RuntimeTableBuilder builder{context, result};
1254
    builder.DescribeTypes(context.globalScope(), false);
1255
  }
1256
  return result;
1257
}
1258

1259
// Find the type of a defined I/O procedure's interface's initial "dtv"
1260
// dummy argument.  Returns a non-null DeclTypeSpec pointer only if that
1261
// dtv argument exists and is a derived type.
1262
static const DeclTypeSpec *GetDefinedIoSpecificArgType(const Symbol &specific) {
1263
  const Symbol *interface{&specific.GetUltimate()};
1264
  if (const auto *procEntity{specific.detailsIf<ProcEntityDetails>()}) {
1265
    interface = procEntity->procInterface();
1266
  }
1267
  if (interface) {
1268
    if (const SubprogramDetails *
1269
            subprogram{interface->detailsIf<SubprogramDetails>()};
1270
        subprogram && !subprogram->dummyArgs().empty()) {
1271
      if (const Symbol * dtvArg{subprogram->dummyArgs().at(0)}) {
1272
        if (const DeclTypeSpec * declType{dtvArg->GetType()}) {
1273
          return declType->AsDerived() ? declType : nullptr;
1274
        }
1275
      }
1276
    }
1277
  }
1278
  return nullptr;
1279
}
1280

1281
// Locate a particular scope's generic interface for a specific kind of
1282
// defined I/O.
1283
static const Symbol *FindGenericDefinedIo(
1284
    const Scope &scope, common::DefinedIo which) {
1285
  if (const Symbol * symbol{scope.FindSymbol(GenericKind::AsFortran(which))}) {
1286
    const Symbol &generic{symbol->GetUltimate()};
1287
    const auto &genericDetails{generic.get<GenericDetails>()};
1288
    CHECK(std::holds_alternative<common::DefinedIo>(genericDetails.kind().u));
1289
    CHECK(std::get<common::DefinedIo>(genericDetails.kind().u) == which);
1290
    return &generic;
1291
  } else {
1292
    return nullptr;
1293
  }
1294
}
1295

1296
std::multimap<const Symbol *, NonTbpDefinedIo>
1297
CollectNonTbpDefinedIoGenericInterfaces(
1298
    const Scope &scope, bool useRuntimeTypeInfoEntries) {
1299
  std::multimap<const Symbol *, NonTbpDefinedIo> result;
1300
  if (!scope.IsTopLevel() &&
1301
      (scope.GetImportKind() == Scope::ImportKind::All ||
1302
          scope.GetImportKind() == Scope::ImportKind::Default)) {
1303
    result = CollectNonTbpDefinedIoGenericInterfaces(
1304
        scope.parent(), useRuntimeTypeInfoEntries);
1305
  }
1306
  if (scope.kind() != Scope::Kind::DerivedType) {
1307
    for (common::DefinedIo which :
1308
        {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,
1309
            common::DefinedIo::WriteFormatted,
1310
            common::DefinedIo::WriteUnformatted}) {
1311
      if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {
1312
        for (auto specific : generic->get<GenericDetails>().specificProcs()) {
1313
          if (const DeclTypeSpec *
1314
              declType{GetDefinedIoSpecificArgType(*specific)}) {
1315
            const DerivedTypeSpec &derived{DEREF(declType->AsDerived())};
1316
            if (const Symbol *
1317
                dtDesc{derived.scope()
1318
                        ? derived.scope()->runtimeDerivedTypeDescription()
1319
                        : nullptr}) {
1320
              if (useRuntimeTypeInfoEntries &&
1321
                  &derived.scope()->parent() == &generic->owner()) {
1322
                // This non-TBP defined I/O generic was defined in the
1323
                // same scope as the derived type, and it will be
1324
                // included in the derived type's special bindings
1325
                // by IncorporateDefinedIoGenericInterfaces().
1326
              } else {
1327
                // Local scope's specific overrides host's for this type
1328
                bool updated{false};
1329
                for (auto [iter, end]{result.equal_range(dtDesc)}; iter != end;
1330
                     ++iter) {
1331
                  NonTbpDefinedIo &nonTbp{iter->second};
1332
                  if (nonTbp.definedIo == which) {
1333
                    nonTbp.subroutine = &*specific;
1334
                    nonTbp.isDtvArgPolymorphic = declType->IsPolymorphic();
1335
                    updated = true;
1336
                  }
1337
                }
1338
                if (!updated) {
1339
                  result.emplace(dtDesc,
1340
                      NonTbpDefinedIo{
1341
                          &*specific, which, declType->IsPolymorphic()});
1342
                }
1343
              }
1344
            }
1345
          }
1346
        }
1347
      }
1348
    }
1349
  }
1350
  return result;
1351
}
1352

1353
// ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces()
1354
//
1355
// Returns a true result when a kind of defined I/O generic procedure
1356
// has a type (from a symbol or a NAMELIST) such that
1357
// (1) there is a specific procedure matching that type for a non-type-bound
1358
//     generic defined in the scope of the type, and
1359
// (2) that specific procedure is unavailable or overridden in a particular
1360
//     local scope.
1361
// Specific procedures of non-type-bound defined I/O generic interfaces
1362
// declared in the scope of a derived type are identified as special bindings
1363
// in the derived type's runtime type information, as if they had been
1364
// type-bound.  This predicate is meant to determine local situations in
1365
// which those special bindings are not to be used.  Its result is intended
1366
// to be put into the "ignoreNonTbpEntries" flag of
1367
// runtime::NonTbpDefinedIoTable and passed (negated) as the
1368
// "useRuntimeTypeInfoEntries" argument of
1369
// CollectNonTbpDefinedIoGenericInterfaces() above.
1370

1371
static const Symbol *FindSpecificDefinedIo(const Scope &scope,
1372
    const evaluate::DynamicType &derived, common::DefinedIo which) {
1373
  if (const Symbol * generic{FindGenericDefinedIo(scope, which)}) {
1374
    for (auto ref : generic->get<GenericDetails>().specificProcs()) {
1375
      const Symbol &specific{*ref};
1376
      if (const DeclTypeSpec *
1377
          thisType{GetDefinedIoSpecificArgType(specific)}) {
1378
        if (evaluate::DynamicType{DEREF(thisType->AsDerived()), true}
1379
                .IsTkCompatibleWith(derived)) {
1380
          return &specific.GetUltimate();
1381
        }
1382
      }
1383
    }
1384
  }
1385
  return nullptr;
1386
}
1387

1388
bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1389
    const Scope &scope, const DerivedTypeSpec *derived) {
1390
  if (!derived) {
1391
    return false;
1392
  }
1393
  const Symbol &typeSymbol{derived->typeSymbol()};
1394
  const Scope &typeScope{typeSymbol.GetUltimate().owner()};
1395
  evaluate::DynamicType dyType{*derived};
1396
  for (common::DefinedIo which :
1397
      {common::DefinedIo::ReadFormatted, common::DefinedIo::ReadUnformatted,
1398
          common::DefinedIo::WriteFormatted,
1399
          common::DefinedIo::WriteUnformatted}) {
1400
    if (const Symbol *
1401
        specific{FindSpecificDefinedIo(typeScope, dyType, which)}) {
1402
      // There's a non-TBP defined I/O procedure in the scope of the type's
1403
      // definition that applies to this type.  It will appear in the type's
1404
      // runtime information.  Determine whether it still applies in the
1405
      // scope of interest.
1406
      if (FindSpecificDefinedIo(scope, dyType, which) != specific) {
1407
        return true;
1408
      }
1409
    }
1410
  }
1411
  return false;
1412
}
1413

1414
bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1415
    const Scope &scope, const DeclTypeSpec *type) {
1416
  return type &&
1417
      ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1418
          scope, type->AsDerived());
1419
}
1420

1421
bool ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1422
    const Scope &scope, const Symbol *symbol) {
1423
  if (!symbol) {
1424
    return false;
1425
  }
1426
  return common::visit(
1427
      common::visitors{
1428
          [&](const NamelistDetails &x) {
1429
            for (auto ref : x.objects()) {
1430
              if (ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1431
                      scope, &*ref)) {
1432
                return true;
1433
              }
1434
            }
1435
            return false;
1436
          },
1437
          [&](const auto &) {
1438
            return ShouldIgnoreRuntimeTypeInfoNonTbpGenericInterfaces(
1439
                scope, symbol->GetType());
1440
          },
1441
      },
1442
      symbol->GetUltimate().details());
1443
}
1444

1445
} // namespace Fortran::semantics
1446