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
FindLenParameterIndex(const SymbolVector & parameters,const Symbol & symbol)23 static int FindLenParameterIndex(
24 const SymbolVector ¶meters, 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, bool inSchemata);
42
43 private:
44 const Symbol *DescribeType(Scope &);
45 const Symbol &GetSchemaSymbol(const char *) const;
46 const DeclTypeSpec &GetSchema(const char *) const;
47 SomeExpr GetEnumValue(const char *) const;
48 Symbol &CreateObject(const std::string &, const DeclTypeSpec &, Scope &);
49 // The names of created symbols are saved in and owned by the
50 // RuntimeDerivedTypeTables instance returned by
51 // BuildRuntimeDerivedTypeTables() so that references to those names remain
52 // valid for lowering.
53 SourceName SaveObjectName(const std::string &);
54 SomeExpr SaveNameAsPointerTarget(Scope &, const std::string &);
55 const SymbolVector *GetTypeParameters(const Symbol &);
56 evaluate::StructureConstructor DescribeComponent(const Symbol &,
57 const ObjectEntityDetails &, Scope &, Scope &,
58 const std::string &distinctName, const SymbolVector *parameters);
59 evaluate::StructureConstructor DescribeComponent(
60 const Symbol &, const ProcEntityDetails &, Scope &);
61 bool InitializeDataPointer(evaluate::StructureConstructorValues &,
62 const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
63 Scope &dtScope, const std::string &distinctName);
64 evaluate::StructureConstructor PackageIntValue(
65 const SomeExpr &genre, std::int64_t = 0) const;
66 SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const;
67 std::vector<const Symbol *> CollectBindings(const Scope &dtScope) const;
68 std::vector<evaluate::StructureConstructor> DescribeBindings(
69 const Scope &dtScope, Scope &);
70 void DescribeGeneric(
71 const GenericDetails &, std::vector<evaluate::StructureConstructor> &);
72 void DescribeSpecialProc(std::vector<evaluate::StructureConstructor> &,
73 const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
74 std::optional<GenericKind::DefinedIo>);
75 void IncorporateDefinedIoGenericInterfaces(
76 std::vector<evaluate::StructureConstructor> &, SourceName,
77 GenericKind::DefinedIo, const Scope *);
78
79 // Instantiated for ParamValue and Bound
80 template <typename A>
GetValue(const A & x,const SymbolVector * parameters)81 evaluate::StructureConstructor GetValue(
82 const A &x, const SymbolVector *parameters) {
83 if (x.isExplicit()) {
84 return GetValue(x.GetExplicit(), parameters);
85 } else {
86 return PackageIntValue(deferredEnum_);
87 }
88 }
89
90 // Specialization for optional<Expr<SomeInteger and SubscriptInteger>>
91 template <typename T>
GetValue(const std::optional<evaluate::Expr<T>> & expr,const SymbolVector * parameters)92 evaluate::StructureConstructor GetValue(
93 const std::optional<evaluate::Expr<T>> &expr,
94 const SymbolVector *parameters) {
95 if (auto constValue{evaluate::ToInt64(expr)}) {
96 return PackageIntValue(explicitEnum_, *constValue);
97 }
98 if (expr) {
99 if (parameters) {
100 if (const Symbol * lenParam{evaluate::ExtractBareLenParameter(*expr)}) {
101 return PackageIntValue(
102 lenParameterEnum_, FindLenParameterIndex(*parameters, *lenParam));
103 }
104 }
105 context_.Say(location_,
106 "Specification expression '%s' is neither constant nor a length "
107 "type parameter"_err_en_US,
108 expr->AsFortran());
109 }
110 return PackageIntValue(deferredEnum_);
111 }
112
113 SemanticsContext &context_;
114 RuntimeDerivedTypeTables &tables_;
115 std::map<const Symbol *, SymbolVector> orderedTypeParameters_;
116 int anonymousTypes_{0};
117
118 const DeclTypeSpec &derivedTypeSchema_; // TYPE(DerivedType)
119 const DeclTypeSpec &componentSchema_; // TYPE(Component)
120 const DeclTypeSpec &procPtrSchema_; // TYPE(ProcPtrComponent)
121 const DeclTypeSpec &valueSchema_; // TYPE(Value)
122 const DeclTypeSpec &bindingSchema_; // TYPE(Binding)
123 const DeclTypeSpec &specialSchema_; // TYPE(SpecialBinding)
124 SomeExpr deferredEnum_; // Value::Genre::Deferred
125 SomeExpr explicitEnum_; // Value::Genre::Explicit
126 SomeExpr lenParameterEnum_; // Value::Genre::LenParameter
127 SomeExpr assignmentEnum_; // SpecialBinding::Which::Assignment
128 SomeExpr
129 elementalAssignmentEnum_; // SpecialBinding::Which::ElementalAssignment
130 SomeExpr finalEnum_; // SpecialBinding::Which::Final
131 SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal
132 SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal
133 SomeExpr readFormattedEnum_; // SpecialBinding::Which::ReadFormatted
134 SomeExpr readUnformattedEnum_; // SpecialBinding::Which::ReadUnformatted
135 SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted
136 SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted
137 parser::CharBlock location_;
138 std::set<const Scope *> ignoreScopes_;
139 };
140
RuntimeTableBuilder(SemanticsContext & c,RuntimeDerivedTypeTables & t)141 RuntimeTableBuilder::RuntimeTableBuilder(
142 SemanticsContext &c, RuntimeDerivedTypeTables &t)
143 : context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")},
144 componentSchema_{GetSchema("component")}, procPtrSchema_{GetSchema(
145 "procptrcomponent")},
146 valueSchema_{GetSchema("value")}, bindingSchema_{GetSchema("binding")},
147 specialSchema_{GetSchema("specialbinding")}, deferredEnum_{GetEnumValue(
148 "deferred")},
149 explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue(
150 "lenparameter")},
151 assignmentEnum_{GetEnumValue("assignment")},
152 elementalAssignmentEnum_{GetEnumValue("elementalassignment")},
153 finalEnum_{GetEnumValue("final")}, elementalFinalEnum_{GetEnumValue(
154 "elementalfinal")},
155 assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")},
156 readFormattedEnum_{GetEnumValue("readformatted")},
157 readUnformattedEnum_{GetEnumValue("readunformatted")},
158 writeFormattedEnum_{GetEnumValue("writeformatted")},
159 writeUnformattedEnum_{GetEnumValue("writeunformatted")} {
160 ignoreScopes_.insert(tables_.schemata);
161 }
162
DescribeTypes(Scope & scope,bool inSchemata)163 void RuntimeTableBuilder::DescribeTypes(Scope &scope, bool inSchemata) {
164 inSchemata |= ignoreScopes_.find(&scope) != ignoreScopes_.end();
165 if (scope.IsDerivedType()) {
166 if (!inSchemata) { // don't loop trying to describe a schema
167 DescribeType(scope);
168 }
169 } else {
170 scope.InstantiateDerivedTypes();
171 }
172 for (Scope &child : scope.children()) {
173 DescribeTypes(child, inSchemata);
174 }
175 }
176
177 // Returns derived type instantiation's parameters in declaration order
GetTypeParameters(const Symbol & symbol)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
GetContainingNonDerivedScope(Scope & scope)190 static Scope &GetContainingNonDerivedScope(Scope &scope) {
191 Scope *p{&scope};
192 while (p->IsDerivedType()) {
193 p = &p->parent();
194 }
195 return *p;
196 }
197
GetSchemaField(const DerivedTypeSpec & derived,const std::string & name)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
GetSchemaField(const DeclTypeSpec & derived,const std::string & name)207 static const Symbol &GetSchemaField(
208 const DeclTypeSpec &derived, const std::string &name) {
209 return GetSchemaField(DEREF(derived.AsDerived()), name);
210 }
211
AddValue(evaluate::StructureConstructorValues & values,const DeclTypeSpec & spec,const std::string & name,SomeExpr && x)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
AddValue(evaluate::StructureConstructorValues & values,const DeclTypeSpec & spec,const std::string & name,const SomeExpr & x)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
IntToExpr(std::int64_t n)226 static SomeExpr IntToExpr(std::int64_t n) {
227 return evaluate::AsGenericExpr(evaluate::ExtentExpr{n});
228 }
229
Structure(const DeclTypeSpec & spec,evaluate::StructureConstructorValues && values)230 static evaluate::StructureConstructor Structure(
231 const DeclTypeSpec &spec, evaluate::StructureConstructorValues &&values) {
232 return {DEREF(spec.AsDerived()), std::move(values)};
233 }
234
StructureExpr(evaluate::StructureConstructor && x)235 static SomeExpr StructureExpr(evaluate::StructureConstructor &&x) {
236 return SomeExpr{evaluate::Expr<evaluate::SomeDerived>{std::move(x)}};
237 }
238
GetIntegerKind(const Symbol & symbol)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>
SaveNumericPointerTarget(Scope & scope,SourceName name,std::vector<typename T::Scalar> && x)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.
SaveDerivedPointerTarget(Scope & scope,SourceName name,std::vector<evaluate::StructureConstructor> && x,evaluate::ConstantSubscripts && shape)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
SaveObjectInit(Scope & scope,SourceName name,const ObjectEntityDetails & object)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
IntExpr(std::int64_t n)324 template <int KIND> static SomeExpr IntExpr(std::int64_t n) {
325 return evaluate::AsGenericExpr(
326 evaluate::Constant<evaluate::Type<TypeCategory::Integer, KIND>>{n});
327 }
328
DescribeType(Scope & dtScope)329 const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
330 if (const Symbol * info{dtScope.runtimeDerivedTypeDescription()}) {
331 return info;
332 }
333 const DerivedTypeSpec *derivedTypeSpec{dtScope.derivedTypeSpec()};
334 if (!derivedTypeSpec && !dtScope.IsParameterizedDerivedType() &&
335 dtScope.symbol()) {
336 // This derived type was declared (obviously, there's a Scope) but never
337 // used in this compilation (no instantiated DerivedTypeSpec points here).
338 // Create a DerivedTypeSpec now for it so that ComponentIterator
339 // will work. This covers the case of a derived type that's declared in
340 // a module but used only by clients and submodules, enabling the
341 // run-time "no initialization needed here" flag to work.
342 DerivedTypeSpec derived{dtScope.symbol()->name(), *dtScope.symbol()};
343 DeclTypeSpec &decl{
344 dtScope.MakeDerivedType(DeclTypeSpec::TypeDerived, std::move(derived))};
345 derivedTypeSpec = &decl.derivedTypeSpec();
346 }
347 const Symbol *dtSymbol{
348 derivedTypeSpec ? &derivedTypeSpec->typeSymbol() : dtScope.symbol()};
349 if (!dtSymbol) {
350 return nullptr;
351 }
352 auto locationRestorer{common::ScopedSet(location_, dtSymbol->name())};
353 // Check for an existing description that can be imported from a USE'd module
354 std::string typeName{dtSymbol->name().ToString()};
355 if (typeName.empty() || typeName[0] == '.') {
356 return nullptr;
357 }
358 std::string distinctName{typeName};
359 if (&dtScope != dtSymbol->scope()) {
360 distinctName += "."s + std::to_string(anonymousTypes_++);
361 }
362 std::string dtDescName{".dt."s + distinctName};
363 Scope &scope{GetContainingNonDerivedScope(dtScope)};
364 if (distinctName == typeName && scope.IsModule()) {
365 if (const Symbol * description{scope.FindSymbol(SourceName{dtDescName})}) {
366 dtScope.set_runtimeDerivedTypeDescription(*description);
367 return description;
368 }
369 }
370 // Create a new description object before populating it so that mutual
371 // references will work as pointer targets.
372 Symbol &dtObject{CreateObject(dtDescName, derivedTypeSchema_, scope)};
373 dtScope.set_runtimeDerivedTypeDescription(dtObject);
374 evaluate::StructureConstructorValues dtValues;
375 AddValue(dtValues, derivedTypeSchema_, "name"s,
376 SaveNameAsPointerTarget(scope, typeName));
377 bool isPDTdefinition{
378 !derivedTypeSpec && dtScope.IsParameterizedDerivedType()};
379 if (!isPDTdefinition) {
380 auto sizeInBytes{static_cast<common::ConstantSubscript>(dtScope.size())};
381 if (auto alignment{dtScope.alignment().value_or(0)}) {
382 sizeInBytes += alignment - 1;
383 sizeInBytes /= alignment;
384 sizeInBytes *= alignment;
385 }
386 AddValue(
387 dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes));
388 }
389 bool isPDTinstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
390 if (isPDTinstantiation) {
391 // is PDT instantiation
392 const Symbol *uninstDescObject{
393 DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))};
394 AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
395 evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
396 evaluate::Designator<evaluate::SomeDerived>{
397 DEREF(uninstDescObject)}}));
398 } else {
399 AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
400 SomeExpr{evaluate::NullPointer{}});
401 }
402
403 // TODO: compute typeHash
404
405 using Int8 = evaluate::Type<TypeCategory::Integer, 8>;
406 using Int1 = evaluate::Type<TypeCategory::Integer, 1>;
407 std::vector<Int8::Scalar> kinds;
408 std::vector<Int1::Scalar> lenKinds;
409 const SymbolVector *parameters{GetTypeParameters(*dtSymbol)};
410 if (parameters) {
411 // Package the derived type's parameters in declaration order for
412 // each category of parameter. KIND= type parameters are described
413 // by their instantiated (or default) values, while LEN= type
414 // parameters are described by their INTEGER kinds.
415 for (SymbolRef ref : *parameters) {
416 const auto &tpd{ref->get<TypeParamDetails>()};
417 if (tpd.attr() == common::TypeParamAttr::Kind) {
418 auto value{evaluate::ToInt64(tpd.init()).value_or(0)};
419 if (derivedTypeSpec) {
420 if (const auto *pv{derivedTypeSpec->FindParameter(ref->name())}) {
421 if (pv->GetExplicit()) {
422 if (auto instantiatedValue{
423 evaluate::ToInt64(*pv->GetExplicit())}) {
424 value = *instantiatedValue;
425 }
426 }
427 }
428 }
429 kinds.emplace_back(value);
430 } else { // LEN= parameter
431 lenKinds.emplace_back(GetIntegerKind(*ref));
432 }
433 }
434 }
435 AddValue(dtValues, derivedTypeSchema_, "kindparameter"s,
436 SaveNumericPointerTarget<Int8>(
437 scope, SaveObjectName(".kp."s + distinctName), std::move(kinds)));
438 AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s,
439 SaveNumericPointerTarget<Int1>(
440 scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds)));
441 // Traverse the components of the derived type
442 if (!isPDTdefinition) {
443 std::vector<const Symbol *> dataComponentSymbols;
444 std::vector<evaluate::StructureConstructor> procPtrComponents;
445 std::vector<evaluate::StructureConstructor> specials;
446 for (const auto &pair : dtScope) {
447 const Symbol &symbol{*pair.second};
448 auto locationRestorer{common::ScopedSet(location_, symbol.name())};
449 std::visit(
450 common::visitors{
451 [&](const TypeParamDetails &) {
452 // already handled above in declaration order
453 },
454 [&](const ObjectEntityDetails &) {
455 dataComponentSymbols.push_back(&symbol);
456 },
457 [&](const ProcEntityDetails &proc) {
458 if (IsProcedurePointer(symbol)) {
459 procPtrComponents.emplace_back(
460 DescribeComponent(symbol, proc, scope));
461 }
462 },
463 [&](const ProcBindingDetails &) { // handled in a later pass
464 },
465 [&](const GenericDetails &generic) {
466 DescribeGeneric(generic, specials);
467 },
468 [&](const auto &) {
469 common::die(
470 "unexpected details on symbol '%s' in derived type scope",
471 symbol.name().ToString().c_str());
472 },
473 },
474 symbol.details());
475 }
476 // Sort the data component symbols by offset before emitting them
477 std::sort(dataComponentSymbols.begin(), dataComponentSymbols.end(),
478 [](const Symbol *x, const Symbol *y) {
479 return x->offset() < y->offset();
480 });
481 std::vector<evaluate::StructureConstructor> dataComponents;
482 for (const Symbol *symbol : dataComponentSymbols) {
483 auto locationRestorer{common::ScopedSet(location_, symbol->name())};
484 dataComponents.emplace_back(
485 DescribeComponent(*symbol, symbol->get<ObjectEntityDetails>(), scope,
486 dtScope, distinctName, parameters));
487 }
488 AddValue(dtValues, derivedTypeSchema_, "component"s,
489 SaveDerivedPointerTarget(scope, SaveObjectName(".c."s + distinctName),
490 std::move(dataComponents),
491 evaluate::ConstantSubscripts{
492 static_cast<evaluate::ConstantSubscript>(
493 dataComponents.size())}));
494 AddValue(dtValues, derivedTypeSchema_, "procptr"s,
495 SaveDerivedPointerTarget(scope, SaveObjectName(".p."s + distinctName),
496 std::move(procPtrComponents),
497 evaluate::ConstantSubscripts{
498 static_cast<evaluate::ConstantSubscript>(
499 procPtrComponents.size())}));
500 // Compile the "vtable" of type-bound procedure bindings
501 std::vector<evaluate::StructureConstructor> bindings{
502 DescribeBindings(dtScope, scope)};
503 AddValue(dtValues, derivedTypeSchema_, "binding"s,
504 SaveDerivedPointerTarget(scope, SaveObjectName(".v."s + distinctName),
505 std::move(bindings),
506 evaluate::ConstantSubscripts{
507 static_cast<evaluate::ConstantSubscript>(bindings.size())}));
508 // Describe "special" bindings to defined assignments, FINAL subroutines,
509 // and user-defined derived type I/O subroutines.
510 if (dtScope.symbol()) {
511 for (const auto &pair :
512 dtScope.symbol()->get<DerivedTypeDetails>().finals()) {
513 DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/,
514 true, std::nullopt);
515 }
516 }
517 IncorporateDefinedIoGenericInterfaces(specials,
518 SourceName{"read(formatted)", 15},
519 GenericKind::DefinedIo::ReadFormatted, &scope);
520 IncorporateDefinedIoGenericInterfaces(specials,
521 SourceName{"read(unformatted)", 17},
522 GenericKind::DefinedIo::ReadUnformatted, &scope);
523 IncorporateDefinedIoGenericInterfaces(specials,
524 SourceName{"write(formatted)", 16},
525 GenericKind::DefinedIo::WriteFormatted, &scope);
526 IncorporateDefinedIoGenericInterfaces(specials,
527 SourceName{"write(unformatted)", 18},
528 GenericKind::DefinedIo::WriteUnformatted, &scope);
529 AddValue(dtValues, derivedTypeSchema_, "special"s,
530 SaveDerivedPointerTarget(scope, SaveObjectName(".s."s + distinctName),
531 std::move(specials),
532 evaluate::ConstantSubscripts{
533 static_cast<evaluate::ConstantSubscript>(specials.size())}));
534 // Note the presence/absence of a parent component
535 AddValue(dtValues, derivedTypeSchema_, "hasparent"s,
536 IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr));
537 // To avoid wasting run time attempting to initialize derived type
538 // instances without any initialized components, analyze the type
539 // and set a flag if there's nothing to do for it at run time.
540 AddValue(dtValues, derivedTypeSchema_, "noinitializationneeded"s,
541 IntExpr<1>(
542 derivedTypeSpec && !derivedTypeSpec->HasDefaultInitialization()));
543 // Similarly, a flag to short-circuit destruction when not needed.
544 AddValue(dtValues, derivedTypeSchema_, "nodestructionneeded"s,
545 IntExpr<1>(derivedTypeSpec && !derivedTypeSpec->HasDestruction()));
546 }
547 dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{
548 StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});
549 return &dtObject;
550 }
551
GetSymbol(const Scope & schemata,SourceName name)552 static const Symbol &GetSymbol(const Scope &schemata, SourceName name) {
553 auto iter{schemata.find(name)};
554 CHECK(iter != schemata.end());
555 const Symbol &symbol{*iter->second};
556 return symbol;
557 }
558
GetSchemaSymbol(const char * name) const559 const Symbol &RuntimeTableBuilder::GetSchemaSymbol(const char *name) const {
560 return GetSymbol(
561 DEREF(tables_.schemata), SourceName{name, std::strlen(name)});
562 }
563
GetSchema(const char * schemaName) const564 const DeclTypeSpec &RuntimeTableBuilder::GetSchema(
565 const char *schemaName) const {
566 Scope &schemata{DEREF(tables_.schemata)};
567 SourceName name{schemaName, std::strlen(schemaName)};
568 const Symbol &symbol{GetSymbol(schemata, name)};
569 CHECK(symbol.has<DerivedTypeDetails>());
570 CHECK(symbol.scope());
571 CHECK(symbol.scope()->IsDerivedType());
572 const DeclTypeSpec *spec{nullptr};
573 if (symbol.scope()->derivedTypeSpec()) {
574 DeclTypeSpec typeSpec{
575 DeclTypeSpec::TypeDerived, *symbol.scope()->derivedTypeSpec()};
576 spec = schemata.FindType(typeSpec);
577 }
578 if (!spec) {
579 DeclTypeSpec typeSpec{
580 DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}};
581 spec = schemata.FindType(typeSpec);
582 }
583 if (!spec) {
584 spec = &schemata.MakeDerivedType(
585 DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol});
586 }
587 CHECK(spec->AsDerived());
588 return *spec;
589 }
590
GetEnumValue(const char * name) const591 SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const {
592 const Symbol &symbol{GetSchemaSymbol(name)};
593 auto value{evaluate::ToInt64(symbol.get<ObjectEntityDetails>().init())};
594 CHECK(value.has_value());
595 return IntExpr<1>(*value);
596 }
597
CreateObject(const std::string & name,const DeclTypeSpec & type,Scope & scope)598 Symbol &RuntimeTableBuilder::CreateObject(
599 const std::string &name, const DeclTypeSpec &type, Scope &scope) {
600 ObjectEntityDetails object;
601 object.set_type(type);
602 auto pair{scope.try_emplace(SaveObjectName(name),
603 Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))};
604 CHECK(pair.second);
605 Symbol &result{*pair.first->second};
606 return result;
607 }
608
SaveObjectName(const std::string & name)609 SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) {
610 return *tables_.names.insert(name).first;
611 }
612
SaveNameAsPointerTarget(Scope & scope,const std::string & name)613 SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(
614 Scope &scope, const std::string &name) {
615 CHECK(!name.empty());
616 CHECK(name.front() != '.');
617 ObjectEntityDetails object;
618 auto len{static_cast<common::ConstantSubscript>(name.size())};
619 if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{
620 ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) {
621 object.set_type(*spec);
622 } else {
623 object.set_type(scope.MakeCharacterType(
624 ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}));
625 }
626 using Ascii = evaluate::Type<TypeCategory::Character, 1>;
627 using AsciiExpr = evaluate::Expr<Ascii>;
628 object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));
629 const Symbol &symbol{
630 *scope
631 .try_emplace(SaveObjectName(".n."s + name),
632 Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
633 .first->second};
634 return evaluate::AsGenericExpr(
635 AsciiExpr{evaluate::Designator<Ascii>{symbol}});
636 }
637
DescribeComponent(const Symbol & symbol,const ObjectEntityDetails & object,Scope & scope,Scope & dtScope,const std::string & distinctName,const SymbolVector * parameters)638 evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
639 const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
640 Scope &dtScope, const std::string &distinctName,
641 const SymbolVector *parameters) {
642 evaluate::StructureConstructorValues values;
643 auto &foldingContext{context_.foldingContext()};
644 auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
645 symbol, foldingContext)};
646 CHECK(typeAndShape.has_value());
647 auto dyType{typeAndShape->type()};
648 const auto &shape{typeAndShape->shape()};
649 AddValue(values, componentSchema_, "name"s,
650 SaveNameAsPointerTarget(scope, symbol.name().ToString()));
651 AddValue(values, componentSchema_, "category"s,
652 IntExpr<1>(static_cast<int>(dyType.category())));
653 if (dyType.IsUnlimitedPolymorphic() ||
654 dyType.category() == TypeCategory::Derived) {
655 AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
656 } else {
657 AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
658 }
659 AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
660 // CHARACTER length
661 auto len{typeAndShape->LEN()};
662 if (const semantics::DerivedTypeSpec *
663 pdtInstance{dtScope.derivedTypeSpec()}) {
664 auto restorer{foldingContext.WithPDTInstance(*pdtInstance)};
665 len = Fold(foldingContext, std::move(len));
666 }
667 if (dyType.category() == TypeCategory::Character && len) {
668 AddValue(values, componentSchema_, "characterlen"s,
669 evaluate::AsGenericExpr(GetValue(len, parameters)));
670 } else {
671 AddValue(values, componentSchema_, "characterlen"s,
672 PackageIntValueExpr(deferredEnum_));
673 }
674 // Describe component's derived type
675 std::vector<evaluate::StructureConstructor> lenParams;
676 if (dyType.category() == TypeCategory::Derived &&
677 !dyType.IsUnlimitedPolymorphic()) {
678 const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};
679 Scope *derivedScope{const_cast<Scope *>(
680 spec.scope() ? spec.scope() : spec.typeSymbol().scope())};
681 const Symbol *derivedDescription{DescribeType(DEREF(derivedScope))};
682 AddValue(values, componentSchema_, "derived"s,
683 evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
684 evaluate::Designator<evaluate::SomeDerived>{
685 DEREF(derivedDescription)}}));
686 // Package values of LEN parameters, if any
687 if (const SymbolVector * specParams{GetTypeParameters(spec.typeSymbol())}) {
688 for (SymbolRef ref : *specParams) {
689 const auto &tpd{ref->get<TypeParamDetails>()};
690 if (tpd.attr() == common::TypeParamAttr::Len) {
691 if (const ParamValue * paramValue{spec.FindParameter(ref->name())}) {
692 lenParams.emplace_back(GetValue(*paramValue, parameters));
693 } else {
694 lenParams.emplace_back(GetValue(tpd.init(), parameters));
695 }
696 }
697 }
698 }
699 } else {
700 // Subtle: a category of Derived with a null derived type pointer
701 // signifies CLASS(*)
702 AddValue(values, componentSchema_, "derived"s,
703 SomeExpr{evaluate::NullPointer{}});
704 }
705 // LEN type parameter values for the component's type
706 if (!lenParams.empty()) {
707 AddValue(values, componentSchema_, "lenvalue"s,
708 SaveDerivedPointerTarget(scope,
709 SaveObjectName(
710 ".lv."s + distinctName + "."s + symbol.name().ToString()),
711 std::move(lenParams),
712 evaluate::ConstantSubscripts{
713 static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
714 } else {
715 AddValue(values, componentSchema_, "lenvalue"s,
716 SomeExpr{evaluate::NullPointer{}});
717 }
718 // Shape information
719 int rank{evaluate::GetRank(shape)};
720 AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
721 if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
722 std::vector<evaluate::StructureConstructor> bounds;
723 evaluate::NamedEntity entity{symbol};
724 for (int j{0}; j < rank; ++j) {
725 bounds.emplace_back(GetValue(std::make_optional(evaluate::GetLowerBound(
726 foldingContext, entity, j)),
727 parameters));
728 bounds.emplace_back(GetValue(
729 evaluate::GetUpperBound(foldingContext, entity, j), parameters));
730 }
731 AddValue(values, componentSchema_, "bounds"s,
732 SaveDerivedPointerTarget(scope,
733 SaveObjectName(
734 ".b."s + distinctName + "."s + symbol.name().ToString()),
735 std::move(bounds), evaluate::ConstantSubscripts{2, rank}));
736 } else {
737 AddValue(
738 values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});
739 }
740 // Default component initialization
741 bool hasDataInit{false};
742 if (IsAllocatable(symbol)) {
743 AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
744 } else if (IsPointer(symbol)) {
745 AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
746 hasDataInit = InitializeDataPointer(
747 values, symbol, object, scope, dtScope, distinctName);
748 } else if (IsAutomaticObject(symbol)) {
749 AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));
750 } else {
751 AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));
752 hasDataInit = object.init().has_value();
753 if (hasDataInit) {
754 AddValue(values, componentSchema_, "initialization"s,
755 SaveObjectInit(scope,
756 SaveObjectName(
757 ".di."s + distinctName + "."s + symbol.name().ToString()),
758 object));
759 }
760 }
761 if (!hasDataInit) {
762 AddValue(values, componentSchema_, "initialization"s,
763 SomeExpr{evaluate::NullPointer{}});
764 }
765 return {DEREF(componentSchema_.AsDerived()), std::move(values)};
766 }
767
DescribeComponent(const Symbol & symbol,const ProcEntityDetails & proc,Scope & scope)768 evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
769 const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {
770 evaluate::StructureConstructorValues values;
771 AddValue(values, procPtrSchema_, "name"s,
772 SaveNameAsPointerTarget(scope, symbol.name().ToString()));
773 AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
774 if (auto init{proc.init()}; init && *init) {
775 AddValue(values, procPtrSchema_, "initialization"s,
776 SomeExpr{evaluate::ProcedureDesignator{**init}});
777 } else {
778 AddValue(values, procPtrSchema_, "initialization"s,
779 SomeExpr{evaluate::NullPointer{}});
780 }
781 return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};
782 }
783
784 // Create a static pointer object with the same initialization
785 // from whence the runtime can memcpy() the data pointer
786 // component initialization.
787 // Creates and interconnects the symbols, scopes, and types for
788 // TYPE :: ptrDt
789 // type, POINTER :: name
790 // END TYPE
791 // TYPE(ptrDt), TARGET, SAVE :: ptrInit = ptrDt(designator)
792 // and then initializes the original component by setting
793 // initialization = ptrInit
794 // which takes the address of ptrInit because the type is C_PTR.
795 // This technique of wrapping the data pointer component into
796 // a derived type instance disables any reason for lowering to
797 // attempt to dereference the RHS of an initializer, thereby
798 // allowing the runtime to actually perform the initialization
799 // by means of a simple memcpy() of the wrapped descriptor in
800 // ptrInit to the data pointer component being initialized.
InitializeDataPointer(evaluate::StructureConstructorValues & values,const Symbol & symbol,const ObjectEntityDetails & object,Scope & scope,Scope & dtScope,const std::string & distinctName)801 bool RuntimeTableBuilder::InitializeDataPointer(
802 evaluate::StructureConstructorValues &values, const Symbol &symbol,
803 const ObjectEntityDetails &object, Scope &scope, Scope &dtScope,
804 const std::string &distinctName) {
805 if (object.init().has_value()) {
806 SourceName ptrDtName{SaveObjectName(
807 ".dp."s + distinctName + "."s + symbol.name().ToString())};
808 Symbol &ptrDtSym{
809 *scope.try_emplace(ptrDtName, Attrs{}, UnknownDetails{}).first->second};
810 Scope &ptrDtScope{scope.MakeScope(Scope::Kind::DerivedType, &ptrDtSym)};
811 ignoreScopes_.insert(&ptrDtScope);
812 ObjectEntityDetails ptrDtObj;
813 ptrDtObj.set_type(DEREF(object.type()));
814 ptrDtObj.set_shape(object.shape());
815 Symbol &ptrDtComp{*ptrDtScope
816 .try_emplace(symbol.name(), Attrs{Attr::POINTER},
817 std::move(ptrDtObj))
818 .first->second};
819 DerivedTypeDetails ptrDtDetails;
820 ptrDtDetails.add_component(ptrDtComp);
821 ptrDtSym.set_details(std::move(ptrDtDetails));
822 ptrDtSym.set_scope(&ptrDtScope);
823 DeclTypeSpec &ptrDtDeclType{
824 scope.MakeDerivedType(DeclTypeSpec::Category::TypeDerived,
825 DerivedTypeSpec{ptrDtName, ptrDtSym})};
826 DerivedTypeSpec &ptrDtDerived{DEREF(ptrDtDeclType.AsDerived())};
827 ptrDtDerived.set_scope(ptrDtScope);
828 ptrDtDerived.CookParameters(context_.foldingContext());
829 ptrDtDerived.Instantiate(scope);
830 ObjectEntityDetails ptrInitObj;
831 ptrInitObj.set_type(ptrDtDeclType);
832 evaluate::StructureConstructorValues ptrInitValues;
833 AddValue(
834 ptrInitValues, ptrDtDeclType, symbol.name().ToString(), *object.init());
835 ptrInitObj.set_init(evaluate::AsGenericExpr(
836 Structure(ptrDtDeclType, std::move(ptrInitValues))));
837 AddValue(values, componentSchema_, "initialization"s,
838 SaveObjectInit(scope,
839 SaveObjectName(
840 ".di."s + distinctName + "."s + symbol.name().ToString()),
841 ptrInitObj));
842 return true;
843 } else {
844 return false;
845 }
846 }
847
PackageIntValue(const SomeExpr & genre,std::int64_t n) const848 evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(
849 const SomeExpr &genre, std::int64_t n) const {
850 evaluate::StructureConstructorValues xs;
851 AddValue(xs, valueSchema_, "genre"s, genre);
852 AddValue(xs, valueSchema_, "value"s, IntToExpr(n));
853 return Structure(valueSchema_, std::move(xs));
854 }
855
PackageIntValueExpr(const SomeExpr & genre,std::int64_t n) const856 SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
857 const SomeExpr &genre, std::int64_t n) const {
858 return StructureExpr(PackageIntValue(genre, n));
859 }
860
CollectBindings(const Scope & dtScope) const861 std::vector<const Symbol *> RuntimeTableBuilder::CollectBindings(
862 const Scope &dtScope) const {
863 std::vector<const Symbol *> result;
864 std::map<SourceName, const Symbol *> localBindings;
865 // Collect local bindings
866 for (auto pair : dtScope) {
867 const Symbol &symbol{*pair.second};
868 if (symbol.has<ProcBindingDetails>()) {
869 localBindings.emplace(symbol.name(), &symbol);
870 }
871 }
872 if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
873 result = CollectBindings(*parentScope);
874 // Apply overrides from the local bindings of the extended type
875 for (auto iter{result.begin()}; iter != result.end(); ++iter) {
876 const Symbol &symbol{**iter};
877 auto overridden{localBindings.find(symbol.name())};
878 if (overridden != localBindings.end()) {
879 *iter = overridden->second;
880 localBindings.erase(overridden);
881 }
882 }
883 }
884 // Add remaining (non-overriding) local bindings in name order to the result
885 for (auto pair : localBindings) {
886 result.push_back(pair.second);
887 }
888 return result;
889 }
890
891 std::vector<evaluate::StructureConstructor>
DescribeBindings(const Scope & dtScope,Scope & scope)892 RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) {
893 std::vector<evaluate::StructureConstructor> result;
894 for (const Symbol *symbol : CollectBindings(dtScope)) {
895 evaluate::StructureConstructorValues values;
896 AddValue(values, bindingSchema_, "proc"s,
897 SomeExpr{evaluate::ProcedureDesignator{
898 symbol->get<ProcBindingDetails>().symbol()}});
899 AddValue(values, bindingSchema_, "name"s,
900 SaveNameAsPointerTarget(scope, symbol->name().ToString()));
901 result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
902 }
903 return result;
904 }
905
DescribeGeneric(const GenericDetails & generic,std::vector<evaluate::StructureConstructor> & specials)906 void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
907 std::vector<evaluate::StructureConstructor> &specials) {
908 std::visit(common::visitors{
909 [&](const GenericKind::OtherKind &k) {
910 if (k == GenericKind::OtherKind::Assignment) {
911 for (auto ref : generic.specificProcs()) {
912 DescribeSpecialProc(specials, *ref, true,
913 false /*!final*/, std::nullopt);
914 }
915 }
916 },
917 [&](const GenericKind::DefinedIo &io) {
918 switch (io) {
919 case GenericKind::DefinedIo::ReadFormatted:
920 case GenericKind::DefinedIo::ReadUnformatted:
921 case GenericKind::DefinedIo::WriteFormatted:
922 case GenericKind::DefinedIo::WriteUnformatted:
923 for (auto ref : generic.specificProcs()) {
924 DescribeSpecialProc(
925 specials, *ref, false, false /*!final*/, io);
926 }
927 break;
928 }
929 },
930 [](const auto &) {},
931 },
932 generic.kind().u);
933 }
934
DescribeSpecialProc(std::vector<evaluate::StructureConstructor> & specials,const Symbol & specificOrBinding,bool isAssignment,bool isFinal,std::optional<GenericKind::DefinedIo> io)935 void RuntimeTableBuilder::DescribeSpecialProc(
936 std::vector<evaluate::StructureConstructor> &specials,
937 const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
938 std::optional<GenericKind::DefinedIo> io) {
939 const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
940 const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
941 if (auto proc{evaluate::characteristics::Procedure::Characterize(
942 specific, context_.foldingContext())}) {
943 std::uint8_t rank{0};
944 std::uint8_t isArgDescriptorSet{0};
945 int argThatMightBeDescriptor{0};
946 MaybeExpr which;
947 if (isAssignment) { // only type-bound asst's are germane to runtime
948 CHECK(binding != nullptr);
949 CHECK(proc->dummyArguments.size() == 2);
950 which = proc->IsElemental() ? elementalAssignmentEnum_ : assignmentEnum_;
951 if (binding && binding->passName() &&
952 *binding->passName() == proc->dummyArguments[1].name) {
953 argThatMightBeDescriptor = 1;
954 isArgDescriptorSet |= 2;
955 } else {
956 argThatMightBeDescriptor = 2; // the non-passed-object argument
957 isArgDescriptorSet |= 1;
958 }
959 } else if (isFinal) {
960 CHECK(binding == nullptr); // FINALs are not bindings
961 CHECK(proc->dummyArguments.size() == 1);
962 if (proc->IsElemental()) {
963 which = elementalFinalEnum_;
964 } else {
965 const auto &typeAndShape{
966 std::get<evaluate::characteristics::DummyDataObject>(
967 proc->dummyArguments.at(0).u)
968 .type};
969 if (typeAndShape.attrs().test(
970 evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
971 which = assumedRankFinalEnum_;
972 isArgDescriptorSet |= 1;
973 } else {
974 which = finalEnum_;
975 rank = evaluate::GetRank(typeAndShape.shape());
976 if (rank > 0) {
977 argThatMightBeDescriptor = 1;
978 }
979 }
980 }
981 } else { // user defined derived type I/O
982 CHECK(proc->dummyArguments.size() >= 4);
983 if (binding) {
984 isArgDescriptorSet |= 1;
985 }
986 switch (io.value()) {
987 case GenericKind::DefinedIo::ReadFormatted:
988 which = readFormattedEnum_;
989 break;
990 case GenericKind::DefinedIo::ReadUnformatted:
991 which = readUnformattedEnum_;
992 break;
993 case GenericKind::DefinedIo::WriteFormatted:
994 which = writeFormattedEnum_;
995 break;
996 case GenericKind::DefinedIo::WriteUnformatted:
997 which = writeUnformattedEnum_;
998 break;
999 }
1000 }
1001 if (argThatMightBeDescriptor != 0 &&
1002 !proc->dummyArguments.at(argThatMightBeDescriptor - 1)
1003 .CanBePassedViaImplicitInterface()) {
1004 isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
1005 }
1006 evaluate::StructureConstructorValues values;
1007 AddValue(
1008 values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
1009 AddValue(values, specialSchema_, "rank"s, IntExpr<1>(rank));
1010 AddValue(values, specialSchema_, "isargdescriptorset"s,
1011 IntExpr<1>(isArgDescriptorSet));
1012 AddValue(values, specialSchema_, "proc"s,
1013 SomeExpr{evaluate::ProcedureDesignator{specific}});
1014 specials.emplace_back(DEREF(specialSchema_.AsDerived()), std::move(values));
1015 }
1016 }
1017
IncorporateDefinedIoGenericInterfaces(std::vector<evaluate::StructureConstructor> & specials,SourceName name,GenericKind::DefinedIo definedIo,const Scope * scope)1018 void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
1019 std::vector<evaluate::StructureConstructor> &specials, SourceName name,
1020 GenericKind::DefinedIo definedIo, const Scope *scope) {
1021 for (; !scope->IsGlobal(); scope = &scope->parent()) {
1022 if (auto asst{scope->find(name)}; asst != scope->end()) {
1023 const Symbol &generic{*asst->second};
1024 const auto &genericDetails{generic.get<GenericDetails>()};
1025 CHECK(std::holds_alternative<GenericKind::DefinedIo>(
1026 genericDetails.kind().u));
1027 CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==
1028 definedIo);
1029 for (auto ref : genericDetails.specificProcs()) {
1030 DescribeSpecialProc(specials, *ref, false, false, definedIo);
1031 }
1032 }
1033 }
1034 }
1035
BuildRuntimeDerivedTypeTables(SemanticsContext & context)1036 RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
1037 SemanticsContext &context) {
1038 ModFileReader reader{context};
1039 RuntimeDerivedTypeTables result;
1040 static const char schemataName[]{"__fortran_type_info"};
1041 SourceName schemataModule{schemataName, std::strlen(schemataName)};
1042 result.schemata = reader.Read(schemataModule);
1043 if (result.schemata) {
1044 RuntimeTableBuilder builder{context, result};
1045 builder.DescribeTypes(context.globalScope(), false);
1046 }
1047 return result;
1048 }
1049 } // namespace Fortran::semantics
1050