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