[llvm-branch-commits] [flang] 4fede8b - [flang] Implement derived type description table encoding
peter klausler via llvm-branch-commits
llvm-branch-commits at lists.llvm.org
Tue Dec 8 10:31:15 PST 2020
Author: peter klausler
Date: 2020-12-08T10:26:58-08:00
New Revision: 4fede8bc8a015477f2a8feeb30a1d2a2e155106d
URL: https://github.com/llvm/llvm-project/commit/4fede8bc8a015477f2a8feeb30a1d2a2e155106d
DIFF: https://github.com/llvm/llvm-project/commit/4fede8bc8a015477f2a8feeb30a1d2a2e155106d.diff
LOG: [flang] Implement derived type description table encoding
Define Fortran derived types that describe the characteristics
of derived types, and instantiations of parameterized derived
types, that are of relevance to the runtime language support
library. Define a suite of corresponding C++ structure types
for the runtime library to use to interpret instances of the
descriptions.
Create instances of these description types in Semantics as
static initializers for compiler-created objects in the scopes
that define or instantiate user derived types.
Delete obsolete code from earlier attempts to package runtime
type information.
Differential Revision: https://reviews.llvm.org/D92802
Added:
flang/include/flang/Semantics/runtime-type-info.h
flang/lib/Semantics/runtime-type-info.cpp
flang/module/__fortran_type_info.f90
flang/runtime/derived.cpp
flang/runtime/derived.h
flang/runtime/type-info.h
flang/test/Semantics/typeinfo01.f90
Modified:
flang/docs/RuntimeTypeInfo.md
flang/include/flang/Semantics/scope.h
flang/lib/Semantics/CMakeLists.txt
flang/lib/Semantics/compute-offsets.cpp
flang/lib/Semantics/semantics.cpp
flang/lib/Semantics/tools.cpp
flang/module/__fortran_builtins.f90
flang/module/iso_c_binding.f90
flang/runtime/CMakeLists.txt
flang/runtime/allocatable.cpp
flang/runtime/allocatable.h
flang/runtime/descriptor.cpp
flang/runtime/descriptor.h
flang/runtime/transformational.cpp
flang/tools/f18/CMakeLists.txt
flang/tools/f18/f18.cpp
Removed:
flang/runtime/derived-type.cpp
flang/runtime/derived-type.h
################################################################################
diff --git a/flang/docs/RuntimeTypeInfo.md b/flang/docs/RuntimeTypeInfo.md
index 2a511b208d0e..391b6ea5f88b 100644
--- a/flang/docs/RuntimeTypeInfo.md
+++ b/flang/docs/RuntimeTypeInfo.md
@@ -216,7 +216,7 @@ So the derived type information for a defined assignment needs to
comprise:
* address(es) of the subroutine
* whether the first, second, or both arguments are descriptors
-* whether the subroutine is elemental
+* whether the subroutine is elemental (necessarily also impure)
### User defined derived type I/O
diff --git a/flang/include/flang/Semantics/runtime-type-info.h b/flang/include/flang/Semantics/runtime-type-info.h
new file mode 100644
index 000000000000..71b5cac58eb5
--- /dev/null
+++ b/flang/include/flang/Semantics/runtime-type-info.h
@@ -0,0 +1,38 @@
+//===-- include/flang/Semantics/runtime-type-info.h -------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+// BuildRuntimeDerivedTypeTables() translates the scopes of derived types
+// and parameterized derived type instantiations into the type descriptions
+// defined in module/__fortran_type_info.f90, packaging these descriptions
+// as static initializers for compiler-created objects.
+
+#ifndef FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_
+#define FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_
+
+#include <set>
+#include <string>
+
+namespace llvm {
+class raw_ostream;
+}
+
+namespace Fortran::semantics {
+class Scope;
+class SemanticsContext;
+class Symbol;
+
+struct RuntimeDerivedTypeTables {
+ Scope *schemata{nullptr};
+ std::set<std::string> names;
+};
+
+RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(SemanticsContext &);
+
+void Dump(llvm::raw_ostream &, const RuntimeDerivedTypeTables &);
+} // namespace Fortran::semantics
+#endif // FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_
diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h
index cae94dfac9e8..535e2bd50dce 100644
--- a/flang/include/flang/Semantics/scope.h
+++ b/flang/include/flang/Semantics/scope.h
@@ -197,8 +197,11 @@ class Scope {
std::size_t size() const { return size_; }
void set_size(std::size_t size) { size_ = size; }
- std::size_t alignment() const { return alignment_; }
- void set_alignment(std::size_t alignment) { alignment_ = alignment; }
+ std::optional<std::size_t> alignment() const { return alignment_; }
+
+ void SetAlignment(std::size_t n) {
+ alignment_ = std::max(alignment_.value_or(0), n);
+ }
ImportKind GetImportKind() const;
// Names appearing in IMPORT statements in this scope
@@ -242,11 +245,18 @@ class Scope {
void InstantiateDerivedTypes(SemanticsContext &);
+ const Symbol *runtimeDerivedTypeDescription() const {
+ return runtimeDerivedTypeDescription_;
+ }
+ void set_runtimeDerivedTypeDescription(const Symbol &symbol) {
+ runtimeDerivedTypeDescription_ = &symbol;
+ }
+
private:
Scope &parent_; // this is enclosing scope, not extended derived type base
const Kind kind_;
std::size_t size_{0}; // size in bytes
- std::size_t alignment_{0}; // required alignment in bytes
+ std::optional<std::size_t> alignment_; // required alignment in bytes
parser::CharBlock sourceRange_;
Symbol *const symbol_; // if not null, symbol_->scope() == this
std::list<Scope> children_;
@@ -261,6 +271,7 @@ class Scope {
DerivedTypeSpec *derivedTypeSpec_{nullptr}; // dTS->scope() == this
parser::Message::Reference instantiationContext_;
bool hasSAVE_{false}; // scope has a bare SAVE statement
+ const Symbol *runtimeDerivedTypeDescription_{nullptr};
// When additional data members are added to Scope, remember to
// copy them, if appropriate, in InstantiateDerivedType().
diff --git a/flang/lib/Semantics/CMakeLists.txt b/flang/lib/Semantics/CMakeLists.txt
index 9eb521ecc060..4bab4b16149d 100644
--- a/flang/lib/Semantics/CMakeLists.txt
+++ b/flang/lib/Semantics/CMakeLists.txt
@@ -36,6 +36,7 @@ add_flang_library(FortranSemantics
resolve-names-utils.cpp
resolve-names.cpp
rewrite-parse-tree.cpp
+ runtime-type-info.cpp
scope.cpp
semantics.cpp
symbol.cpp
diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp
index f2a3a10bb4fa..107491da791b 100644
--- a/flang/lib/Semantics/compute-offsets.cpp
+++ b/flang/lib/Semantics/compute-offsets.cpp
@@ -85,12 +85,16 @@ void ComputeOffsetsHelper::DoScope(Scope &scope) {
if (scope.symbol() && scope.IsParameterizedDerivedType()) {
return; // only process instantiations of parameterized derived types
}
+ if (scope.alignment().has_value()) {
+ return; // prevent infinite recursion in error cases
+ }
+ scope.SetAlignment(0);
// Build dependents_ from equivalences: symbol -> symbol+offset
for (const EquivalenceSet &set : scope.equivalenceSets()) {
DoEquivalenceSet(set);
}
offset_ = 0;
- alignment_ = 0;
+ alignment_ = 1;
// Compute a base symbol and overall block size for each
// disjoint EQUIVALENCE storage sequence.
for (auto &[symbol, dep] : dependents_) {
@@ -128,7 +132,7 @@ void ComputeOffsetsHelper::DoScope(Scope &scope) {
}
}
scope.set_size(offset_);
- scope.set_alignment(alignment_);
+ scope.SetAlignment(alignment_);
// Assign offsets in COMMON blocks.
for (auto &pair : scope.commonBlocks()) {
DoCommonBlock(*pair.second);
@@ -357,8 +361,9 @@ auto ComputeOffsetsHelper::GetElementSize(const Symbol &symbol)
}
} else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
if (derived->scope()) {
+ DoScope(*const_cast<Scope *>(derived->scope()));
result.size = derived->scope()->size();
- result.alignment = derived->scope()->alignment();
+ result.alignment = derived->scope()->alignment().value_or(0);
}
} else {
DIE("not intrinsic or derived");
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
new file mode 100644
index 000000000000..dd47aa8eef27
--- /dev/null
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -0,0 +1,964 @@
+//===-- lib/Semantics/runtime-type-info.cpp ---------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Semantics/runtime-type-info.h"
+#include "mod-file.h"
+#include "flang/Evaluate/fold-designator.h"
+#include "flang/Evaluate/fold.h"
+#include "flang/Evaluate/tools.h"
+#include "flang/Evaluate/type.h"
+#include "flang/Semantics/scope.h"
+#include "flang/Semantics/tools.h"
+#include <list>
+#include <map>
+#include <string>
+
+namespace Fortran::semantics {
+
+static int FindLenParameterIndex(
+ const SymbolVector ¶meters, const Symbol &symbol) {
+ int lenIndex{0};
+ for (SymbolRef ref : parameters) {
+ if (&*ref == &symbol) {
+ return lenIndex;
+ }
+ if (ref->get<TypeParamDetails>().attr() == common::TypeParamAttr::Len) {
+ ++lenIndex;
+ }
+ }
+ DIE("Length type parameter not found in parameter order");
+ return -1;
+}
+
+class RuntimeTableBuilder {
+public:
+ RuntimeTableBuilder(SemanticsContext &, RuntimeDerivedTypeTables &);
+ void DescribeTypes(Scope &scope);
+
+private:
+ const Symbol *DescribeType(Scope &);
+ const Symbol &GetSchemaSymbol(const char *) const;
+ const DeclTypeSpec &GetSchema(const char *) const;
+ SomeExpr GetEnumValue(const char *) const;
+ Symbol &CreateObject(const std::string &, const DeclTypeSpec &, Scope &);
+ // The names of created symbols are saved in and owned by the
+ // RuntimeDerivedTypeTables instance returned by
+ // BuildRuntimeDerivedTypeTables() so that references to those names remain
+ // valid for lowering.
+ SourceName SaveObjectName(const std::string &);
+ SomeExpr SaveNameAsPointerTarget(Scope &, const std::string &);
+ const SymbolVector *GetTypeParameters(const Symbol &);
+ evaluate::StructureConstructor DescribeComponent(const Symbol &,
+ const ObjectEntityDetails &, Scope &, const std::string &distinctName,
+ const SymbolVector *parameters);
+ evaluate::StructureConstructor DescribeComponent(
+ const Symbol &, const ProcEntityDetails &, Scope &);
+ evaluate::StructureConstructor PackageIntValue(
+ const SomeExpr &genre, std::int64_t = 0) const;
+ SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const;
+ std::vector<const Symbol *> CollectBindings(const Scope &dtScope) const;
+ std::vector<evaluate::StructureConstructor> DescribeBindings(
+ const Scope &dtScope, Scope &);
+ void DescribeGeneric(
+ const GenericDetails &, std::vector<evaluate::StructureConstructor> &);
+ void DescribeSpecialProc(std::vector<evaluate::StructureConstructor> &,
+ const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
+ std::optional<GenericKind::DefinedIo>);
+ void IncorporateDefinedIoGenericInterfaces(
+ std::vector<evaluate::StructureConstructor> &, SourceName,
+ GenericKind::DefinedIo, const Scope *);
+
+ // Instantiated for ParamValue and Bound
+ template <typename A>
+ evaluate::StructureConstructor GetValue(
+ const A &x, const SymbolVector *parameters) {
+ if (x.isExplicit()) {
+ return GetValue(x.GetExplicit(), parameters);
+ } else {
+ return PackageIntValue(deferredEnum_);
+ }
+ }
+
+ // Specialization for optional<Expr<SomeInteger and SubscriptInteger>>
+ template <typename T>
+ evaluate::StructureConstructor GetValue(
+ const std::optional<evaluate::Expr<T>> &expr,
+ const SymbolVector *parameters) {
+ if (auto constValue{evaluate::ToInt64(expr)}) {
+ return PackageIntValue(explicitEnum_, *constValue);
+ }
+ if (parameters) {
+ if (const auto *typeParam{
+ evaluate::UnwrapExpr<evaluate::TypeParamInquiry>(expr)}) {
+ if (!typeParam->base()) {
+ const Symbol &symbol{typeParam->parameter()};
+ if (const auto *tpd{symbol.detailsIf<TypeParamDetails>()}) {
+ if (tpd->attr() == common::TypeParamAttr::Len) {
+ return PackageIntValue(lenParameterEnum_,
+ FindLenParameterIndex(*parameters, symbol));
+ }
+ }
+ }
+ }
+ }
+ if (expr) {
+ context_.Say(location_,
+ "Specification expression '%s' is neither constant nor a length type parameter"_err_en_US,
+ expr->AsFortran());
+ }
+ return PackageIntValue(deferredEnum_);
+ }
+
+ SemanticsContext &context_;
+ RuntimeDerivedTypeTables &tables_;
+ std::map<const Symbol *, SymbolVector> orderedTypeParameters_;
+ int anonymousTypes_{0};
+
+ const DeclTypeSpec &derivedTypeSchema_; // TYPE(DerivedType)
+ const DeclTypeSpec &componentSchema_; // TYPE(Component)
+ const DeclTypeSpec &procPtrSchema_; // TYPE(ProcPtrComponent)
+ const DeclTypeSpec &valueSchema_; // TYPE(Value)
+ const DeclTypeSpec &bindingSchema_; // TYPE(Binding)
+ const DeclTypeSpec &specialSchema_; // TYPE(SpecialBinding)
+ SomeExpr deferredEnum_; // Value::Genre::Deferred
+ SomeExpr explicitEnum_; // Value::Genre::Explicit
+ SomeExpr lenParameterEnum_; // Value::Genre::LenParameter
+ SomeExpr assignmentEnum_; // SpecialBinding::Which::Assignment
+ SomeExpr
+ elementalAssignmentEnum_; // SpecialBinding::Which::ElementalAssignment
+ SomeExpr finalEnum_; // SpecialBinding::Which::Final
+ SomeExpr elementalFinalEnum_; // SpecialBinding::Which::ElementalFinal
+ SomeExpr assumedRankFinalEnum_; // SpecialBinding::Which::AssumedRankFinal
+ SomeExpr readFormattedEnum_; // SpecialBinding::Which::ReadFormatted
+ SomeExpr readUnformattedEnum_; // SpecialBinding::Which::ReadUnformatted
+ SomeExpr writeFormattedEnum_; // SpecialBinding::Which::WriteFormatted
+ SomeExpr writeUnformattedEnum_; // SpecialBinding::Which::WriteUnformatted
+ parser::CharBlock location_;
+};
+
+RuntimeTableBuilder::RuntimeTableBuilder(
+ SemanticsContext &c, RuntimeDerivedTypeTables &t)
+ : context_{c}, tables_{t}, derivedTypeSchema_{GetSchema("derivedtype")},
+ componentSchema_{GetSchema("component")}, procPtrSchema_{GetSchema(
+ "procptrcomponent")},
+ valueSchema_{GetSchema("value")}, bindingSchema_{GetSchema("binding")},
+ specialSchema_{GetSchema("specialbinding")}, deferredEnum_{GetEnumValue(
+ "deferred")},
+ explicitEnum_{GetEnumValue("explicit")}, lenParameterEnum_{GetEnumValue(
+ "lenparameter")},
+ assignmentEnum_{GetEnumValue("assignment")},
+ elementalAssignmentEnum_{GetEnumValue("elementalassignment")},
+ finalEnum_{GetEnumValue("final")}, elementalFinalEnum_{GetEnumValue(
+ "elementalfinal")},
+ assumedRankFinalEnum_{GetEnumValue("assumedrankfinal")},
+ readFormattedEnum_{GetEnumValue("readformatted")},
+ readUnformattedEnum_{GetEnumValue("readunformatted")},
+ writeFormattedEnum_{GetEnumValue("writeformatted")},
+ writeUnformattedEnum_{GetEnumValue("writeunformatted")} {}
+
+void RuntimeTableBuilder::DescribeTypes(Scope &scope) {
+ if (&scope == tables_.schemata) {
+ return; // don't loop trying to describe a schema...
+ }
+ if (scope.IsDerivedType()) {
+ DescribeType(scope);
+ } else {
+ for (Scope &child : scope.children()) {
+ DescribeTypes(child);
+ }
+ }
+}
+
+// Returns derived type instantiation's parameters in declaration order
+const SymbolVector *RuntimeTableBuilder::GetTypeParameters(
+ const Symbol &symbol) {
+ auto iter{orderedTypeParameters_.find(&symbol)};
+ if (iter != orderedTypeParameters_.end()) {
+ return &iter->second;
+ } else {
+ return &orderedTypeParameters_
+ .emplace(&symbol, OrderParameterDeclarations(symbol))
+ .first->second;
+ }
+}
+
+static Scope &GetContainingNonDerivedScope(Scope &scope) {
+ Scope *p{&scope};
+ while (p->IsDerivedType()) {
+ p = &p->parent();
+ }
+ return *p;
+}
+
+static const Symbol &GetSchemaField(
+ const DerivedTypeSpec &derived, const std::string &name) {
+ const Scope &scope{
+ DEREF(derived.scope() ? derived.scope() : derived.typeSymbol().scope())};
+ auto iter{scope.find(SourceName(name))};
+ CHECK(iter != scope.end());
+ return *iter->second;
+}
+
+static const Symbol &GetSchemaField(
+ const DeclTypeSpec &derived, const std::string &name) {
+ return GetSchemaField(DEREF(derived.AsDerived()), name);
+}
+
+static evaluate::StructureConstructorValues &AddValue(
+ evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec,
+ const std::string &name, SomeExpr &&x) {
+ values.emplace(GetSchemaField(spec, name), std::move(x));
+ return values;
+}
+
+static evaluate::StructureConstructorValues &AddValue(
+ evaluate::StructureConstructorValues &values, const DeclTypeSpec &spec,
+ const std::string &name, const SomeExpr &x) {
+ values.emplace(GetSchemaField(spec, name), x);
+ return values;
+}
+
+static SomeExpr IntToExpr(std::int64_t n) {
+ return evaluate::AsGenericExpr(evaluate::ExtentExpr{n});
+}
+
+static evaluate::StructureConstructor Structure(
+ const DeclTypeSpec &spec, evaluate::StructureConstructorValues &&values) {
+ return {DEREF(spec.AsDerived()), std::move(values)};
+}
+
+static SomeExpr StructureExpr(evaluate::StructureConstructor &&x) {
+ return SomeExpr{evaluate::Expr<evaluate::SomeDerived>{std::move(x)}};
+}
+
+static int GetIntegerKind(const Symbol &symbol) {
+ auto dyType{evaluate::DynamicType::From(symbol)};
+ CHECK(dyType && dyType->category() == TypeCategory::Integer);
+ return dyType->kind();
+}
+
+// Save a rank-1 array constant of some numeric type as an
+// initialized data object in a scope.
+template <typename T>
+static SomeExpr SaveNumericPointerTarget(
+ Scope &scope, SourceName name, std::vector<typename T::Scalar> &&x) {
+ if (x.empty()) {
+ return SomeExpr{evaluate::NullPointer{}};
+ } else {
+ ObjectEntityDetails object;
+ if (const auto *spec{scope.FindType(
+ DeclTypeSpec{NumericTypeSpec{T::category, KindExpr{T::kind}}})}) {
+ object.set_type(*spec);
+ } else {
+ object.set_type(scope.MakeNumericType(T::category, KindExpr{T::kind}));
+ }
+ auto elements{static_cast<evaluate::ConstantSubscript>(x.size())};
+ ArraySpec arraySpec;
+ arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{elements - 1}));
+ object.set_shape(arraySpec);
+ object.set_init(evaluate::AsGenericExpr(evaluate::Constant<T>{
+ std::move(x), evaluate::ConstantSubscripts{elements}}));
+ const Symbol &symbol{
+ *scope
+ .try_emplace(
+ name, Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
+ .first->second};
+ return evaluate::AsGenericExpr(
+ evaluate::Expr<T>{evaluate::Designator<T>{symbol}});
+ }
+}
+
+// Save an arbitrarily shaped array constant of some derived type
+// as an initialized data object in a scope.
+static SomeExpr SaveDerivedPointerTarget(Scope &scope, SourceName name,
+ std::vector<evaluate::StructureConstructor> &&x,
+ evaluate::ConstantSubscripts &&shape) {
+ if (x.empty()) {
+ return SomeExpr{evaluate::NullPointer{}};
+ } else {
+ const auto &derivedType{x.front().GetType().GetDerivedTypeSpec()};
+ ObjectEntityDetails object;
+ DeclTypeSpec typeSpec{DeclTypeSpec::TypeDerived, derivedType};
+ if (const DeclTypeSpec * spec{scope.FindType(typeSpec)}) {
+ object.set_type(*spec);
+ } else {
+ object.set_type(scope.MakeDerivedType(
+ DeclTypeSpec::TypeDerived, common::Clone(derivedType)));
+ }
+ if (!shape.empty()) {
+ ArraySpec arraySpec;
+ for (auto n : shape) {
+ arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{n - 1}));
+ }
+ object.set_shape(arraySpec);
+ }
+ object.set_init(
+ evaluate::AsGenericExpr(evaluate::Constant<evaluate::SomeDerived>{
+ derivedType, std::move(x), std::move(shape)}));
+ const Symbol &symbol{
+ *scope
+ .try_emplace(
+ name, Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
+ .first->second};
+ return evaluate::AsGenericExpr(
+ evaluate::Designator<evaluate::SomeDerived>{symbol});
+ }
+}
+
+static SomeExpr SaveObjectInit(
+ Scope &scope, SourceName name, const ObjectEntityDetails &object) {
+ const Symbol &symbol{*scope
+ .try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},
+ ObjectEntityDetails{object})
+ .first->second};
+ CHECK(symbol.get<ObjectEntityDetails>().init().has_value());
+ return evaluate::AsGenericExpr(
+ evaluate::Designator<evaluate::SomeDerived>{symbol});
+}
+
+const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
+ if (const Symbol * info{dtScope.runtimeDerivedTypeDescription()}) {
+ return info;
+ }
+ const DerivedTypeSpec *derivedTypeSpec{dtScope.derivedTypeSpec()};
+ const Symbol *dtSymbol{
+ derivedTypeSpec ? &derivedTypeSpec->typeSymbol() : dtScope.symbol()};
+ if (!dtSymbol) {
+ return nullptr;
+ }
+ auto locationRestorer{common::ScopedSet(location_, dtSymbol->name())};
+ // Check for an existing description that can be imported from a USE'd module
+ std::string typeName{dtSymbol->name().ToString()};
+ if (typeName.empty() || typeName[0] == '.') {
+ return nullptr;
+ }
+ std::string distinctName{typeName};
+ if (&dtScope != dtSymbol->scope()) {
+ distinctName += "."s + std::to_string(anonymousTypes_++);
+ }
+ std::string dtDescName{".dt."s + distinctName};
+ Scope &scope{GetContainingNonDerivedScope(dtScope)};
+ if (distinctName == typeName && scope.IsModule()) {
+ if (const Symbol * description{scope.FindSymbol(SourceName{dtDescName})}) {
+ dtScope.set_runtimeDerivedTypeDescription(*description);
+ return description;
+ }
+ }
+ // Create a new description object before populating it so that mutual
+ // references will work as pointer targets.
+ Symbol &dtObject{CreateObject(dtDescName, derivedTypeSchema_, scope)};
+ dtScope.set_runtimeDerivedTypeDescription(dtObject);
+ evaluate::StructureConstructorValues dtValues;
+ AddValue(dtValues, derivedTypeSchema_, "name"s,
+ SaveNameAsPointerTarget(scope, typeName));
+ bool isPDTdefinition{
+ !derivedTypeSpec && dtScope.IsParameterizedDerivedType()};
+ if (!isPDTdefinition) {
+ auto sizeInBytes{static_cast<common::ConstantSubscript>(dtScope.size())};
+ if (auto alignment{dtScope.alignment().value_or(0)}) {
+ sizeInBytes += alignment - 1;
+ sizeInBytes /= alignment;
+ sizeInBytes *= alignment;
+ }
+ AddValue(
+ dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes));
+ }
+ const Symbol *parentDescObject{nullptr};
+ if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
+ parentDescObject = DescribeType(*const_cast<Scope *>(parentScope));
+ }
+ if (parentDescObject) {
+ AddValue(dtValues, derivedTypeSchema_, "parent"s,
+ evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
+ evaluate::Designator<evaluate::SomeDerived>{*parentDescObject}}));
+ } else {
+ AddValue(dtValues, derivedTypeSchema_, "parent"s,
+ SomeExpr{evaluate::NullPointer{}});
+ }
+ bool isPDTinstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
+ if (isPDTinstantiation) {
+ // is PDT instantiation
+ const Symbol *uninstDescObject{
+ DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))};
+ AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
+ evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
+ evaluate::Designator<evaluate::SomeDerived>{
+ DEREF(uninstDescObject)}}));
+ } else {
+ AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
+ SomeExpr{evaluate::NullPointer{}});
+ }
+
+ // TODO: compute typeHash
+
+ using Int8 = evaluate::Type<TypeCategory::Integer, 8>;
+ using Int1 = evaluate::Type<TypeCategory::Integer, 1>;
+ std::vector<Int8::Scalar> kinds;
+ std::vector<Int1::Scalar> lenKinds;
+ const SymbolVector *parameters{GetTypeParameters(*dtSymbol)};
+ if (parameters) {
+ // Package the derived type's parameters in declaration order for
+ // each category of parameter. KIND= type parameters are described
+ // by their instantiated (or default) values, while LEN= type
+ // parameters are described by their INTEGER kinds.
+ for (SymbolRef ref : *parameters) {
+ const auto &tpd{ref->get<TypeParamDetails>()};
+ if (tpd.attr() == common::TypeParamAttr::Kind) {
+ auto value{evaluate::ToInt64(tpd.init()).value_or(0)};
+ if (derivedTypeSpec) {
+ if (const auto *pv{derivedTypeSpec->FindParameter(ref->name())}) {
+ if (pv->GetExplicit()) {
+ if (auto instantiatedValue{
+ evaluate::ToInt64(*pv->GetExplicit())}) {
+ value = *instantiatedValue;
+ }
+ }
+ }
+ }
+ kinds.emplace_back(value);
+ } else { // LEN= parameter
+ lenKinds.emplace_back(GetIntegerKind(*ref));
+ }
+ }
+ }
+ AddValue(dtValues, derivedTypeSchema_, "kindparameter"s,
+ SaveNumericPointerTarget<Int8>(
+ scope, SaveObjectName(".kp."s + distinctName), std::move(kinds)));
+ AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s,
+ SaveNumericPointerTarget<Int1>(
+ scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds)));
+ // Traverse the components of the derived type
+ if (!isPDTdefinition) {
+ std::vector<evaluate::StructureConstructor> dataComponents;
+ std::vector<evaluate::StructureConstructor> procPtrComponents;
+ std::vector<evaluate::StructureConstructor> specials;
+ for (const auto &pair : dtScope) {
+ const Symbol &symbol{*pair.second};
+ auto locationRestorer{common::ScopedSet(location_, symbol.name())};
+ std::visit(
+ common::visitors{
+ [&](const TypeParamDetails &) {
+ // already handled above in declaration order
+ },
+ [&](const ObjectEntityDetails &object) {
+ dataComponents.emplace_back(DescribeComponent(
+ symbol, object, scope, distinctName, parameters));
+ },
+ [&](const ProcEntityDetails &proc) {
+ if (IsProcedurePointer(symbol)) {
+ procPtrComponents.emplace_back(
+ DescribeComponent(symbol, proc, scope));
+ }
+ },
+ [&](const ProcBindingDetails &) { // handled in a later pass
+ },
+ [&](const GenericDetails &generic) {
+ DescribeGeneric(generic, specials);
+ },
+ [&](const auto &) {
+ common::die(
+ "unexpected details on symbol '%s' in derived type scope",
+ symbol.name().ToString().c_str());
+ },
+ },
+ symbol.details());
+ }
+ AddValue(dtValues, derivedTypeSchema_, "component"s,
+ SaveDerivedPointerTarget(scope, SaveObjectName(".c."s + distinctName),
+ std::move(dataComponents),
+ evaluate::ConstantSubscripts{
+ static_cast<evaluate::ConstantSubscript>(
+ dataComponents.size())}));
+ AddValue(dtValues, derivedTypeSchema_, "procptr"s,
+ SaveDerivedPointerTarget(scope, SaveObjectName(".p."s + distinctName),
+ std::move(procPtrComponents),
+ evaluate::ConstantSubscripts{
+ static_cast<evaluate::ConstantSubscript>(
+ procPtrComponents.size())}));
+ // Compile the "vtable" of type-bound procedure bindings
+ std::vector<evaluate::StructureConstructor> bindings{
+ DescribeBindings(dtScope, scope)};
+ AddValue(dtValues, derivedTypeSchema_, "binding"s,
+ SaveDerivedPointerTarget(scope, SaveObjectName(".v."s + distinctName),
+ std::move(bindings),
+ evaluate::ConstantSubscripts{
+ static_cast<evaluate::ConstantSubscript>(bindings.size())}));
+ // Describe "special" bindings to defined assignments, FINAL subroutines,
+ // and user-defined derived type I/O subroutines.
+ if (dtScope.symbol()) {
+ for (const auto &pair :
+ dtScope.symbol()->get<DerivedTypeDetails>().finals()) {
+ DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/,
+ true, std::nullopt);
+ }
+ }
+ IncorporateDefinedIoGenericInterfaces(specials,
+ SourceName{"read(formatted)", 15},
+ GenericKind::DefinedIo::ReadFormatted, &scope);
+ IncorporateDefinedIoGenericInterfaces(specials,
+ SourceName{"read(unformatted)", 17},
+ GenericKind::DefinedIo::ReadUnformatted, &scope);
+ IncorporateDefinedIoGenericInterfaces(specials,
+ SourceName{"write(formatted)", 16},
+ GenericKind::DefinedIo::WriteFormatted, &scope);
+ IncorporateDefinedIoGenericInterfaces(specials,
+ SourceName{"write(unformatted)", 18},
+ GenericKind::DefinedIo::WriteUnformatted, &scope);
+ AddValue(dtValues, derivedTypeSchema_, "special"s,
+ SaveDerivedPointerTarget(scope, SaveObjectName(".s."s + distinctName),
+ std::move(specials),
+ evaluate::ConstantSubscripts{
+ static_cast<evaluate::ConstantSubscript>(specials.size())}));
+ }
+ dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{
+ StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});
+ return &dtObject;
+}
+
+static const Symbol &GetSymbol(const Scope &schemata, SourceName name) {
+ auto iter{schemata.find(name)};
+ CHECK(iter != schemata.end());
+ const Symbol &symbol{*iter->second};
+ return symbol;
+}
+
+const Symbol &RuntimeTableBuilder::GetSchemaSymbol(const char *name) const {
+ return GetSymbol(
+ DEREF(tables_.schemata), SourceName{name, std::strlen(name)});
+}
+
+const DeclTypeSpec &RuntimeTableBuilder::GetSchema(
+ const char *schemaName) const {
+ Scope &schemata{DEREF(tables_.schemata)};
+ SourceName name{schemaName, std::strlen(schemaName)};
+ const Symbol &symbol{GetSymbol(schemata, name)};
+ CHECK(symbol.has<DerivedTypeDetails>());
+ CHECK(symbol.scope());
+ CHECK(symbol.scope()->IsDerivedType());
+ const DeclTypeSpec *spec{nullptr};
+ if (symbol.scope()->derivedTypeSpec()) {
+ DeclTypeSpec typeSpec{
+ DeclTypeSpec::TypeDerived, *symbol.scope()->derivedTypeSpec()};
+ spec = schemata.FindType(typeSpec);
+ }
+ if (!spec) {
+ DeclTypeSpec typeSpec{
+ DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol}};
+ spec = schemata.FindType(typeSpec);
+ }
+ if (!spec) {
+ spec = &schemata.MakeDerivedType(
+ DeclTypeSpec::TypeDerived, DerivedTypeSpec{name, symbol});
+ }
+ CHECK(spec->AsDerived());
+ return *spec;
+}
+
+template <int KIND> static SomeExpr IntExpr(std::int64_t n) {
+ return evaluate::AsGenericExpr(
+ evaluate::Constant<evaluate::Type<TypeCategory::Integer, KIND>>{n});
+}
+
+SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const {
+ const Symbol &symbol{GetSchemaSymbol(name)};
+ auto value{evaluate::ToInt64(symbol.get<ObjectEntityDetails>().init())};
+ CHECK(value.has_value());
+ return IntExpr<1>(*value);
+}
+
+Symbol &RuntimeTableBuilder::CreateObject(
+ const std::string &name, const DeclTypeSpec &type, Scope &scope) {
+ ObjectEntityDetails object;
+ object.set_type(type);
+ auto pair{scope.try_emplace(SaveObjectName(name),
+ Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))};
+ CHECK(pair.second);
+ Symbol &result{*pair.first->second};
+ return result;
+}
+
+SourceName RuntimeTableBuilder::SaveObjectName(const std::string &name) {
+ return *tables_.names.insert(name).first;
+}
+
+SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(
+ Scope &scope, const std::string &name) {
+ CHECK(!name.empty());
+ CHECK(name.front() != '.');
+ ObjectEntityDetails object;
+ auto len{static_cast<common::ConstantSubscript>(name.size())};
+ if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{
+ ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) {
+ object.set_type(*spec);
+ } else {
+ object.set_type(scope.MakeCharacterType(
+ ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}));
+ }
+ using Ascii = evaluate::Type<TypeCategory::Character, 1>;
+ using AsciiExpr = evaluate::Expr<Ascii>;
+ object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));
+ const Symbol &symbol{
+ *scope
+ .try_emplace(SaveObjectName(".n."s + name),
+ Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
+ .first->second};
+ return evaluate::AsGenericExpr(
+ AsciiExpr{evaluate::Designator<Ascii>{symbol}});
+}
+
+evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
+ const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
+ const std::string &distinctName, const SymbolVector *parameters) {
+ evaluate::StructureConstructorValues values;
+ auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
+ object, context_.foldingContext())};
+ CHECK(typeAndShape.has_value());
+ auto dyType{typeAndShape->type()};
+ const auto &shape{typeAndShape->shape()};
+ AddValue(values, componentSchema_, "name"s,
+ SaveNameAsPointerTarget(scope, symbol.name().ToString()));
+ AddValue(values, componentSchema_, "category"s,
+ IntExpr<1>(static_cast<int>(dyType.category())));
+ if (dyType.IsUnlimitedPolymorphic() ||
+ dyType.category() == TypeCategory::Derived) {
+ AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
+ } else {
+ AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
+ }
+ AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
+ // CHARACTER length
+ const auto &len{typeAndShape->LEN()};
+ if (dyType.category() == TypeCategory::Character && len) {
+ AddValue(values, componentSchema_, "characterlen"s,
+ evaluate::AsGenericExpr(GetValue(len, parameters)));
+ } else {
+ AddValue(values, componentSchema_, "characterlen"s,
+ PackageIntValueExpr(deferredEnum_));
+ }
+ // Describe component's derived type
+ std::vector<evaluate::StructureConstructor> lenParams;
+ if (dyType.category() == TypeCategory::Derived &&
+ !dyType.IsUnlimitedPolymorphic()) {
+ const DerivedTypeSpec &spec{dyType.GetDerivedTypeSpec()};
+ Scope *derivedScope{const_cast<Scope *>(
+ spec.scope() ? spec.scope() : spec.typeSymbol().scope())};
+ const Symbol *derivedDescription{DescribeType(DEREF(derivedScope))};
+ AddValue(values, componentSchema_, "derived"s,
+ evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
+ evaluate::Designator<evaluate::SomeDerived>{
+ DEREF(derivedDescription)}}));
+ // Package values of LEN parameters, if any
+ if (const SymbolVector * specParams{GetTypeParameters(spec.typeSymbol())}) {
+ for (SymbolRef ref : *specParams) {
+ const auto &tpd{ref->get<TypeParamDetails>()};
+ if (tpd.attr() == common::TypeParamAttr::Len) {
+ if (const ParamValue * paramValue{spec.FindParameter(ref->name())}) {
+ lenParams.emplace_back(GetValue(*paramValue, parameters));
+ } else {
+ lenParams.emplace_back(GetValue(tpd.init(), parameters));
+ }
+ }
+ }
+ }
+ } else {
+ // Subtle: a category of Derived with a null derived type pointer
+ // signifies CLASS(*)
+ AddValue(values, componentSchema_, "derived"s,
+ SomeExpr{evaluate::NullPointer{}});
+ }
+ // LEN type parameter values for the component's type
+ if (!lenParams.empty()) {
+ AddValue(values, componentSchema_, "lenvalue"s,
+ SaveDerivedPointerTarget(scope,
+ SaveObjectName(
+ ".lv."s + distinctName + "."s + symbol.name().ToString()),
+ std::move(lenParams),
+ evaluate::ConstantSubscripts{
+ static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
+ } else {
+ AddValue(values, componentSchema_, "lenvalue"s,
+ SomeExpr{evaluate::NullPointer{}});
+ }
+ // Shape information
+ int rank{evaluate::GetRank(shape)};
+ AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
+ if (rank > 0) {
+ std::vector<evaluate::StructureConstructor> bounds;
+ evaluate::NamedEntity entity{symbol};
+ auto &foldingContext{context_.foldingContext()};
+ for (int j{0}; j < rank; ++j) {
+ bounds.emplace_back(GetValue(std::make_optional(evaluate::GetLowerBound(
+ foldingContext, entity, j)),
+ parameters));
+ bounds.emplace_back(GetValue(
+ evaluate::GetUpperBound(foldingContext, entity, j), parameters));
+ }
+ AddValue(values, componentSchema_, "bounds"s,
+ SaveDerivedPointerTarget(scope,
+ SaveObjectName(
+ ".b."s + distinctName + "."s + symbol.name().ToString()),
+ std::move(bounds), evaluate::ConstantSubscripts{2, rank}));
+ } else {
+ AddValue(
+ values, componentSchema_, "bounds"s, SomeExpr{evaluate::NullPointer{}});
+ }
+ // Default component initialization
+ bool hasDataInit{false};
+ if (IsAllocatable(symbol)) {
+ AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
+ } else if (IsPointer(symbol)) {
+ AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
+ hasDataInit = object.init().has_value();
+ if (hasDataInit) {
+ AddValue(values, componentSchema_, "initialization"s,
+ SomeExpr{*object.init()});
+ }
+ } else if (IsAutomaticObject(symbol)) {
+ AddValue(values, componentSchema_, "genre"s, GetEnumValue("automatic"));
+ } else {
+ AddValue(values, componentSchema_, "genre"s, GetEnumValue("data"));
+ hasDataInit = object.init().has_value();
+ if (hasDataInit) {
+ AddValue(values, componentSchema_, "initialization"s,
+ SaveObjectInit(scope,
+ SaveObjectName(
+ ".di."s + distinctName + "."s + symbol.name().ToString()),
+ object));
+ }
+ }
+ if (!hasDataInit) {
+ AddValue(values, componentSchema_, "initialization"s,
+ SomeExpr{evaluate::NullPointer{}});
+ }
+ return {DEREF(componentSchema_.AsDerived()), std::move(values)};
+}
+
+evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
+ const Symbol &symbol, const ProcEntityDetails &proc, Scope &scope) {
+ evaluate::StructureConstructorValues values;
+ AddValue(values, procPtrSchema_, "name"s,
+ SaveNameAsPointerTarget(scope, symbol.name().ToString()));
+ AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
+ if (auto init{proc.init()}; init && *init) {
+ AddValue(values, procPtrSchema_, "initialization"s,
+ SomeExpr{evaluate::ProcedureDesignator{**init}});
+ } else {
+ AddValue(values, procPtrSchema_, "initialization"s,
+ SomeExpr{evaluate::NullPointer{}});
+ }
+ return {DEREF(procPtrSchema_.AsDerived()), std::move(values)};
+}
+
+evaluate::StructureConstructor RuntimeTableBuilder::PackageIntValue(
+ const SomeExpr &genre, std::int64_t n) const {
+ evaluate::StructureConstructorValues xs;
+ AddValue(xs, valueSchema_, "genre"s, genre);
+ AddValue(xs, valueSchema_, "value"s, IntToExpr(n));
+ return Structure(valueSchema_, std::move(xs));
+}
+
+SomeExpr RuntimeTableBuilder::PackageIntValueExpr(
+ const SomeExpr &genre, std::int64_t n) const {
+ return StructureExpr(PackageIntValue(genre, n));
+}
+
+std::vector<const Symbol *> RuntimeTableBuilder::CollectBindings(
+ const Scope &dtScope) const {
+ std::vector<const Symbol *> result;
+ std::map<SourceName, const Symbol *> localBindings;
+ // Collect local bindings
+ for (auto pair : dtScope) {
+ const Symbol &symbol{*pair.second};
+ if (symbol.has<ProcBindingDetails>()) {
+ localBindings.emplace(symbol.name(), &symbol);
+ }
+ }
+ if (const Scope * parentScope{dtScope.GetDerivedTypeParent()}) {
+ result = CollectBindings(*parentScope);
+ // Apply overrides from the local bindings of the extended type
+ for (auto iter{result.begin()}; iter != result.end(); ++iter) {
+ const Symbol &symbol{**iter};
+ auto overridden{localBindings.find(symbol.name())};
+ if (overridden != localBindings.end()) {
+ *iter = overridden->second;
+ localBindings.erase(overridden);
+ }
+ }
+ }
+ // Add remaining (non-overriding) local bindings in name order to the result
+ for (auto pair : localBindings) {
+ result.push_back(pair.second);
+ }
+ return result;
+}
+
+std::vector<evaluate::StructureConstructor>
+RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) {
+ std::vector<evaluate::StructureConstructor> result;
+ for (const Symbol *symbol : CollectBindings(dtScope)) {
+ evaluate::StructureConstructorValues values;
+ AddValue(values, bindingSchema_, "proc"s,
+ SomeExpr{evaluate::ProcedureDesignator{
+ symbol->get<ProcBindingDetails>().symbol()}});
+ AddValue(values, bindingSchema_, "name"s,
+ SaveNameAsPointerTarget(scope, symbol->name().ToString()));
+ result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
+ }
+ return result;
+}
+
+void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
+ std::vector<evaluate::StructureConstructor> &specials) {
+ std::visit(common::visitors{
+ [&](const GenericKind::OtherKind &k) {
+ if (k == GenericKind::OtherKind::Assignment) {
+ for (auto ref : generic.specificProcs()) {
+ DescribeSpecialProc(specials, *ref, true,
+ false /*!final*/, std::nullopt);
+ }
+ }
+ },
+ [&](const GenericKind::DefinedIo &io) {
+ switch (io) {
+ case GenericKind::DefinedIo::ReadFormatted:
+ case GenericKind::DefinedIo::ReadUnformatted:
+ case GenericKind::DefinedIo::WriteFormatted:
+ case GenericKind::DefinedIo::WriteUnformatted:
+ for (auto ref : generic.specificProcs()) {
+ DescribeSpecialProc(
+ specials, *ref, false, false /*!final*/, io);
+ }
+ break;
+ }
+ },
+ [](const auto &) {},
+ },
+ generic.kind().u);
+}
+
+void RuntimeTableBuilder::DescribeSpecialProc(
+ std::vector<evaluate::StructureConstructor> &specials,
+ const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
+ std::optional<GenericKind::DefinedIo> io) {
+ const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
+ const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
+ if (auto proc{evaluate::characteristics::Procedure::Characterize(
+ specific, context_.foldingContext())}) {
+ std::uint8_t rank{0};
+ std::uint8_t isArgDescriptorSet{0};
+ int argThatMightBeDescriptor{0};
+ MaybeExpr which;
+ if (isAssignment) { // only type-bound asst's are germane to runtime
+ CHECK(binding != nullptr);
+ CHECK(proc->dummyArguments.size() == 2);
+ which = proc->IsElemental() ? elementalAssignmentEnum_ : assignmentEnum_;
+ if (binding && binding->passName() &&
+ *binding->passName() == proc->dummyArguments[1].name) {
+ argThatMightBeDescriptor = 1;
+ isArgDescriptorSet |= 2;
+ } else {
+ argThatMightBeDescriptor = 2; // the non-passed-object argument
+ isArgDescriptorSet |= 1;
+ }
+ } else if (isFinal) {
+ CHECK(binding == nullptr); // FINALs are not bindings
+ CHECK(proc->dummyArguments.size() == 1);
+ if (proc->IsElemental()) {
+ which = elementalFinalEnum_;
+ } else {
+ const auto &typeAndShape{
+ std::get<evaluate::characteristics::DummyDataObject>(
+ proc->dummyArguments.at(0).u)
+ .type};
+ if (typeAndShape.attrs().test(
+ evaluate::characteristics::TypeAndShape::Attr::AssumedRank)) {
+ which = assumedRankFinalEnum_;
+ isArgDescriptorSet |= 1;
+ } else {
+ which = finalEnum_;
+ rank = evaluate::GetRank(typeAndShape.shape());
+ if (rank > 0) {
+ argThatMightBeDescriptor = 1;
+ }
+ }
+ }
+ } else { // user defined derived type I/O
+ CHECK(proc->dummyArguments.size() >= 4);
+ bool isArg0Descriptor{
+ !proc->dummyArguments.at(0).CanBePassedViaImplicitInterface()};
+ // N.B. When the user defined I/O subroutine is a type bound procedure,
+ // its first argument is always a descriptor, otherwise, when it was an
+ // interface, it never is.
+ CHECK(!!binding == isArg0Descriptor);
+ if (binding) {
+ isArgDescriptorSet |= 1;
+ }
+ switch (io.value()) {
+ case GenericKind::DefinedIo::ReadFormatted:
+ which = readFormattedEnum_;
+ break;
+ case GenericKind::DefinedIo::ReadUnformatted:
+ which = readUnformattedEnum_;
+ break;
+ case GenericKind::DefinedIo::WriteFormatted:
+ which = writeFormattedEnum_;
+ break;
+ case GenericKind::DefinedIo::WriteUnformatted:
+ which = writeUnformattedEnum_;
+ break;
+ }
+ }
+ if (argThatMightBeDescriptor != 0 &&
+ !proc->dummyArguments.at(argThatMightBeDescriptor - 1)
+ .CanBePassedViaImplicitInterface()) {
+ isArgDescriptorSet |= 1 << (argThatMightBeDescriptor - 1);
+ }
+ evaluate::StructureConstructorValues values;
+ AddValue(
+ values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
+ AddValue(values, specialSchema_, "rank"s, IntExpr<1>(rank));
+ AddValue(values, specialSchema_, "isargdescriptorset"s,
+ IntExpr<1>(isArgDescriptorSet));
+ AddValue(values, specialSchema_, "proc"s,
+ SomeExpr{evaluate::ProcedureDesignator{specific}});
+ specials.emplace_back(DEREF(specialSchema_.AsDerived()), std::move(values));
+ }
+}
+
+void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
+ std::vector<evaluate::StructureConstructor> &specials, SourceName name,
+ GenericKind::DefinedIo definedIo, const Scope *scope) {
+ for (; !scope->IsGlobal(); scope = &scope->parent()) {
+ if (auto asst{scope->find(name)}; asst != scope->end()) {
+ const Symbol &generic{*asst->second};
+ const auto &genericDetails{generic.get<GenericDetails>()};
+ CHECK(std::holds_alternative<GenericKind::DefinedIo>(
+ genericDetails.kind().u));
+ CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==
+ definedIo);
+ for (auto ref : genericDetails.specificProcs()) {
+ DescribeSpecialProc(specials, *ref, false, false, definedIo);
+ }
+ }
+ }
+}
+
+RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
+ SemanticsContext &context) {
+ ModFileReader reader{context};
+ RuntimeDerivedTypeTables result;
+ static const char schemataName[]{"__fortran_type_info"};
+ SourceName schemataModule{schemataName, std::strlen(schemataName)};
+ result.schemata = reader.Read(schemataModule);
+ if (result.schemata) {
+ RuntimeTableBuilder builder{context, result};
+ builder.DescribeTypes(context.globalScope());
+ }
+ return result;
+}
+} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp
index b5b7802c22a1..66f985408f20 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -381,8 +381,8 @@ void DoDumpSymbols(llvm::raw_ostream &os, const Scope &scope, int indent) {
if (const auto *symbol{scope.symbol()}) {
os << ' ' << symbol->name();
}
- if (scope.size()) {
- os << " size=" << scope.size() << " alignment=" << scope.alignment();
+ if (scope.alignment().has_value()) {
+ os << " size=" << scope.size() << " alignment=" << *scope.alignment();
}
if (scope.derivedTypeSpec()) {
os << " instantiation of " << *scope.derivedTypeSpec();
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 2c8fd91f033d..7c5ead748ca7 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -490,7 +490,8 @@ bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {
} else {
const auto &symbol{derived->typeSymbol()};
return symbol.owner().IsModule() &&
- symbol.owner().GetName().value() == "__fortran_builtins" &&
+ (symbol.owner().GetName().value() == "__fortran_builtins" ||
+ symbol.owner().GetName().value() == "__fortran_type_info") &&
symbol.name() == "__builtin_"s + name;
}
}
@@ -638,10 +639,16 @@ bool IsAutomatic(const Symbol &symbol) {
}
bool IsFinalizable(const Symbol &symbol) {
- if (const DeclTypeSpec * type{symbol.GetType()}) {
- if (const DerivedTypeSpec * derived{type->AsDerived()}) {
- return IsFinalizable(*derived);
+ if (IsPointer(symbol)) {
+ return false;
+ }
+ if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (object->isDummy() && !IsIntentOut(symbol)) {
+ return false;
}
+ const DeclTypeSpec *type{object->type()};
+ const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
+ return derived && IsFinalizable(*derived);
}
return false;
}
diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90
index 67acad0f4ffd..bdff2a97954b 100644
--- a/flang/module/__fortran_builtins.f90
+++ b/flang/module/__fortran_builtins.f90
@@ -12,27 +12,20 @@
! standard names of the procedures.
module __Fortran_builtins
+ use __Fortran_type_info, only: __builtin_c_ptr, __builtin_c_funptr
integer, parameter, private :: int64 = selected_int_kind(18)
intrinsic :: __builtin_c_f_pointer
- type :: __builtin_c_ptr
- integer(kind=int64) :: __address = 0
- end type
-
- type :: __builtin_c_funptr
- integer(kind=int64) :: __address = 0
- end type
-
type :: __builtin_event_type
- integer(kind=int64) :: __count = 0
+ integer(kind=int64) :: __count
end type
type :: __builtin_lock_type
- integer(kind=int64) :: __count = 0
+ integer(kind=int64) :: __count
end type
type :: __builtin_team_type
- integer(kind=int64) :: __id = 0
+ integer(kind=int64) :: __id
end type
end module
diff --git a/flang/module/__fortran_type_info.f90 b/flang/module/__fortran_type_info.f90
new file mode 100644
index 000000000000..6a2b9dcf25b4
--- /dev/null
+++ b/flang/module/__fortran_type_info.f90
@@ -0,0 +1,115 @@
+!===-- module/__fortran_type_info.f90 --------------------------------------===!
+!
+! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+! See https://llvm.org/LICENSE.txt for license information.
+! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+!
+!===------------------------------------------------------------------------===!
+
+! Fortran definitions of runtime type description schemata.
+! See flang/runtime/type-info.h for C++ perspective.
+! The Semantics phase of the compiler requires the module file of this module
+! in order to generate description tables for all other derived types.
+
+module __Fortran_type_info
+
+ private
+
+ integer, parameter :: int64 = selected_int_kind(18)
+
+ type, public :: __builtin_c_ptr
+ integer(kind=int64) :: __address
+ end type
+
+ type, public :: __builtin_c_funptr
+ integer(kind=int64) :: __address
+ end type
+
+ type :: DerivedType
+ ! "TBP" bindings appear first. Inherited bindings, with overrides already
+ ! applied, appear in the initial entries in the same order as they
+ ! appear in the parent type's bindings, if any. They are followed
+ ! by new local bindings in alphabetic order of theing binding names.
+ type(Binding), pointer :: binding(:)
+ character(len=:), pointer :: name
+ integer(kind=int64) :: sizeInBytes
+ type(DerivedType), pointer :: parent
+ ! Instances of parameterized derived types use the "uninstantiated"
+ ! component to point to the pristine original definition.
+ type(DerivedType), pointer :: uninstantiated
+ integer(kind=int64) :: typeHash
+ integer(kind=int64), pointer :: kindParameter(:) ! values of instance
+ integer(1), pointer :: lenParameterKind(:) ! INTEGER kinds of LEN types
+ ! Data components appear in alphabetic order.
+ ! The parent component, if any, appears explicitly.
+ type(Component), pointer :: component(:) ! data components
+ type(ProcPtrComponent), pointer :: procptr(:) ! procedure pointers
+ ! Special bindings of the ancestral types are not duplicated here.
+ type(SpecialBinding), pointer :: special(:)
+ end type
+
+ type :: Binding
+ type(__builtin_c_funptr) :: proc
+ character(len=:), pointer :: name
+ end type
+
+ ! Array bounds and type parameters of ocmponents are deferred
+ ! (for allocatables and pointers), explicit constants, or
+ ! taken from LEN type parameters for automatic components.
+ enum, bind(c) ! Value::Genre
+ enumerator :: Deferred = 1, Explicit = 2, LenParameter = 3
+ end enum
+
+ type, bind(c) :: Value
+ integer(1) :: genre ! Value::Genre
+ integer(1) :: __padding0(7)
+ integer(kind=int64) :: value
+ end type
+
+ enum, bind(c) ! Component::Genre
+ enumerator :: Data = 1, Pointer = 2, Allocatable = 3, Automatic = 4
+ end enum
+
+ enum, bind(c) ! common::TypeCategory
+ enumerator :: CategoryInteger = 0, CategoryReal = 1, &
+ CategoryComplex = 2, CategoryCharacter = 3, &
+ CategoryLogical = 4, CategoryDerived = 5
+ end enum
+
+ type :: Component ! data components, incl. object pointers
+ character(len=:), pointer :: name
+ integer(1) :: genre ! Component::Genre
+ integer(1) :: category
+ integer(1) :: kind
+ integer(1) :: rank
+ integer(1) :: __padding0(4)
+ integer(kind=int64) :: offset
+ type(Value) :: characterLen ! for category == Character
+ type(DerivedType), pointer :: derived ! for category == Derived
+ type(Value), pointer :: lenValue(:) ! (SIZE(derived%lenParameterKind))
+ type(Value), pointer :: bounds(:, :) ! (2, rank): lower, upper
+ class(*), pointer :: initialization
+ end type
+
+ type :: ProcPtrComponent ! procedure pointer components
+ character(len=:), pointer :: name
+ integer(kind=int64) :: offset
+ type(__builtin_c_funptr) :: initialization
+ end type
+
+ enum, bind(c) ! SpecialBinding::Which
+ enumerator :: Assignment = 4, ElementalAssignment = 5
+ enumerator :: Final = 8, ElementalFinal = 9, AssumedRankFinal = 10
+ enumerator :: ReadFormatted = 16, ReadUnformatted = 17
+ enumerator :: WriteFormatted = 18, WriteUnformatted = 19
+ end enum
+
+ type, bind(c) :: SpecialBinding
+ integer(1) :: which ! SpecialBinding::Which
+ integer(1) :: rank ! for which == SpecialBinding::Which::Final only
+ integer(1) :: isArgDescriptorSet
+ integer(1) :: __padding0(5)
+ type(__builtin_c_funptr) :: proc
+ end type
+
+end module
diff --git a/flang/module/iso_c_binding.f90 b/flang/module/iso_c_binding.f90
index a659f2fc040c..52c28e7a031d 100644
--- a/flang/module/iso_c_binding.f90
+++ b/flang/module/iso_c_binding.f90
@@ -15,8 +15,8 @@ module iso_c_binding
c_ptr => __builtin_c_ptr, &
c_funptr => __builtin_c_funptr
- type(c_ptr), parameter :: c_null_ptr = c_ptr()
- type(c_funptr), parameter :: c_null_funptr = c_funptr()
+ type(c_ptr), parameter :: c_null_ptr = c_ptr(0)
+ type(c_funptr), parameter :: c_null_funptr = c_funptr(0)
! Table 18.2 (in clause 18.3.1)
! TODO: Specialize (via macros?) for alternative targets
diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt
index 2295082fd4ad..005df3b86332 100644
--- a/flang/runtime/CMakeLists.txt
+++ b/flang/runtime/CMakeLists.txt
@@ -36,7 +36,7 @@ add_flang_library(FortranRuntime
buffer.cpp
character.cpp
connection.cpp
- derived-type.cpp
+ derived.cpp
descriptor.cpp
edit-input.cpp
edit-output.cpp
diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp
index 18dc93cdbc6f..182f27110584 100644
--- a/flang/runtime/allocatable.cpp
+++ b/flang/runtime/allocatable.cpp
@@ -29,7 +29,7 @@ void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor,
}
void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
- const DerivedType &derivedType, int rank, int corank) {
+ const typeInfo::DerivedType &derivedType, int rank, int corank) {
INTERNAL_CHECK(corank == 0);
descriptor.Establish(
derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
diff --git a/flang/runtime/allocatable.h b/flang/runtime/allocatable.h
index c65ede2da65e..b5dcb10007bc 100644
--- a/flang/runtime/allocatable.h
+++ b/flang/runtime/allocatable.h
@@ -13,6 +13,10 @@
#include "descriptor.h"
#include "entry-names.h"
+namespace Fortran::runtime::typeInfo {
+class DerivedType;
+}
+
namespace Fortran::runtime {
extern "C" {
@@ -29,7 +33,7 @@ void RTNAME(AllocatableInitIntrinsic)(
void RTNAME(AllocatableInitCharacter)(Descriptor &, SubscriptValue length = 0,
int kind = 1, int rank = 0, int corank = 0);
void RTNAME(AllocatableInitDerived)(
- Descriptor &, const DerivedType &, int rank = 0, int corank = 0);
+ Descriptor &, const typeInfo::DerivedType &, int rank = 0, int corank = 0);
// Checks that an allocatable is not already allocated in statements
// with STAT=. Use this on a value descriptor before setting bounds or
diff --git a/flang/runtime/derived-type.cpp b/flang/runtime/derived-type.cpp
deleted file mode 100644
index e04488b66fab..000000000000
--- a/flang/runtime/derived-type.cpp
+++ /dev/null
@@ -1,77 +0,0 @@
-//===-- runtime/derived-type.cpp ------------------------------------------===//
-//
-// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
-// See https://llvm.org/LICENSE.txt for license information.
-// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
-//
-//===----------------------------------------------------------------------===//
-
-#include "derived-type.h"
-#include "descriptor.h"
-#include <cstring>
-
-namespace Fortran::runtime {
-
-TypeParameterValue TypeParameter::GetValue(const Descriptor &descriptor) const {
- if (which_ < 0) {
- return value_;
- } else {
- return descriptor.Addendum()->LenParameterValue(which_);
- }
-}
-
-bool DerivedType::IsNontrivialAnalysis() const {
- if (kindParameters_ > 0 || lenParameters_ > 0 || typeBoundProcedures_ > 0) {
- return true;
- }
- for (std::size_t j{0}; j < components_; ++j) {
- if (component_[j].IsDescriptor()) {
- return true;
- }
- if (const Descriptor * staticDescriptor{component_[j].staticDescriptor()}) {
- if (const DescriptorAddendum * addendum{staticDescriptor->Addendum()}) {
- if (const DerivedType * dt{addendum->derivedType()}) {
- if (dt->IsNontrivial()) {
- return true;
- }
- }
- }
- }
- }
- return false;
-}
-
-void DerivedType::Initialize(char *instance) const {
- if (typeBoundProcedures_ > InitializerTBP) {
- if (auto f{reinterpret_cast<void (*)(char *)>(
- typeBoundProcedure_[InitializerTBP].code.host)}) {
- f(instance);
- }
- }
-#if 0 // TODO
- for (std::size_t j{0}; j < components_; ++j) {
- if (const Descriptor * descriptor{component_[j].GetDescriptor(instance)}) {
- // invoke initialization TBP
- }
- }
-#endif
-}
-
-void DerivedType::Destroy(char *instance, bool finalize) const {
- if (finalize && typeBoundProcedures_ > FinalTBP) {
- if (auto f{reinterpret_cast<void (*)(char *)>(
- typeBoundProcedure_[FinalTBP].code.host)}) {
- f(instance);
- }
- }
- const char *constInstance{instance};
- for (std::size_t j{0}; j < components_; ++j) {
- if (Descriptor * descriptor{component_[j].GetDescriptor(instance)}) {
- descriptor->Deallocate(finalize);
- } else if (const Descriptor *
- descriptor{component_[j].GetDescriptor(constInstance)}) {
- descriptor->Destroy(component_[j].Locate<char>(instance), finalize);
- }
- }
-}
-} // namespace Fortran::runtime
diff --git a/flang/runtime/derived-type.h b/flang/runtime/derived-type.h
deleted file mode 100644
index 1cb5ba96c00e..000000000000
--- a/flang/runtime/derived-type.h
+++ /dev/null
@@ -1,190 +0,0 @@
-//===-- runtime/derived-type.h ----------------------------------*- C++ -*-===//
-//
-// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
-// See https://llvm.org/LICENSE.txt for license information.
-// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
-//
-//===----------------------------------------------------------------------===//
-
-#ifndef FORTRAN_RUNTIME_DERIVED_TYPE_H_
-#define FORTRAN_RUNTIME_DERIVED_TYPE_H_
-
-#include "type-code.h"
-#include "flang/ISO_Fortran_binding.h"
-#include <cinttypes>
-#include <cstddef>
-
-namespace Fortran::runtime {
-
-class Descriptor;
-
-// Static type information about derived type specializations,
-// suitable for residence in read-only storage.
-
-using TypeParameterValue = ISO::CFI_index_t;
-
-class TypeParameter {
-public:
- const char *name() const { return name_; }
- const TypeCode typeCode() const { return typeCode_; }
-
- bool IsLenTypeParameter() const { return which_ < 0; }
-
- // Returns the static value of a KIND type parameter, or the default
- // value of a LEN type parameter.
- TypeParameterValue StaticValue() const { return value_; }
-
- // Returns the static value of a KIND type parameter, or an
- // instantiated value of LEN type parameter.
- TypeParameterValue GetValue(const Descriptor &) const;
-
-private:
- const char *name_;
- TypeCode typeCode_; // INTEGER, but not necessarily default kind
- int which_{-1}; // index into DescriptorAddendum LEN type parameter values
- TypeParameterValue value_; // default in the case of LEN type parameter
-};
-
-// Components that have any need for a descriptor will either reference
-// a static descriptor that applies to all instances, or will *be* a
-// descriptor. Be advised: the base addresses in static descriptors
-// are null. Most runtime interfaces separate the data address from that
-// of the descriptor, and ignore the encapsulated base address in the
-// descriptor. Some interfaces, e.g. calls to interoperable procedures,
-// cannot pass a separate data address, and any static descriptor being used
-// in that kind of situation must be copied and customized.
-// Static descriptors are flagged in their attributes.
-class Component {
-public:
- const char *name() const { return name_; }
- TypeCode typeCode() const { return typeCode_; }
- const Descriptor *staticDescriptor() const { return staticDescriptor_; }
-
- bool IsParent() const { return (flags_ & PARENT) != 0; }
- bool IsPrivate() const { return (flags_ & PRIVATE) != 0; }
- bool IsDescriptor() const { return (flags_ & IS_DESCRIPTOR) != 0; }
-
- template <typename A> A *Locate(char *dtInstance) const {
- return reinterpret_cast<A *>(dtInstance + offset_);
- }
- template <typename A> const A *Locate(const char *dtInstance) const {
- return reinterpret_cast<const A *>(dtInstance + offset_);
- }
-
- Descriptor *GetDescriptor(char *dtInstance) const {
- if (IsDescriptor()) {
- return Locate<Descriptor>(dtInstance);
- } else {
- return nullptr;
- }
- }
-
- const Descriptor *GetDescriptor(const char *dtInstance) const {
- if (staticDescriptor_) {
- return staticDescriptor_;
- } else if (IsDescriptor()) {
- return Locate<const Descriptor>(dtInstance);
- } else {
- return nullptr;
- }
- }
-
-private:
- enum Flag { PARENT = 1, PRIVATE = 2, IS_DESCRIPTOR = 4 };
- const char *name_{nullptr};
- std::uint32_t flags_{0};
- TypeCode typeCode_{CFI_type_other};
- const Descriptor *staticDescriptor_{nullptr};
- std::size_t offset_{0}; // byte offset in derived type instance
-};
-
-struct ExecutableCode {
- ExecutableCode() {}
- ExecutableCode(const ExecutableCode &) = default;
- ExecutableCode &operator=(const ExecutableCode &) = default;
- std::intptr_t host{0};
- std::intptr_t device{0};
-};
-
-struct TypeBoundProcedure {
- const char *name;
- ExecutableCode code;
-};
-
-// Represents a specialization of a derived type; i.e., any KIND type
-// parameters have values set at compilation time.
-// Extended derived types have the EXTENDS flag set and place their base
-// component first in the component descriptions, which is significant for
-// the execution of FINAL subroutines.
-class DerivedType {
-public:
- DerivedType(const char *n, std::size_t kps, std::size_t lps,
- const TypeParameter *tp, std::size_t cs, const Component *ca,
- std::size_t tbps, const TypeBoundProcedure *tbp, std::size_t sz)
- : name_{n}, kindParameters_{kps}, lenParameters_{lps}, typeParameter_{tp},
- components_{cs}, component_{ca}, typeBoundProcedures_{tbps},
- typeBoundProcedure_{tbp}, bytes_{sz} {
- if (IsNontrivialAnalysis()) {
- flags_ |= NONTRIVIAL;
- }
- }
-
- const char *name() const { return name_; }
- std::size_t kindParameters() const { return kindParameters_; }
- std::size_t lenParameters() const { return lenParameters_; }
-
- // KIND type parameters come first.
- const TypeParameter &typeParameter(int n) const { return typeParameter_[n]; }
-
- std::size_t components() const { return components_; }
-
- // The first few type-bound procedure indices are special.
- enum SpecialTBP { InitializerTBP, CopierTBP, FinalTBP };
-
- std::size_t typeBoundProcedures() const { return typeBoundProcedures_; }
- const TypeBoundProcedure &typeBoundProcedure(int n) const {
- return typeBoundProcedure_[n];
- }
-
- DerivedType &set_sequence() {
- flags_ |= SEQUENCE;
- return *this;
- }
- DerivedType &set_bind_c() {
- flags_ |= BIND_C;
- return *this;
- }
-
- std::size_t SizeInBytes() const { return bytes_; }
- bool Extends() const { return components_ > 0 && component_[0].IsParent(); }
- bool AnyPrivate() const;
- bool IsSequence() const { return (flags_ & SEQUENCE) != 0; }
- bool IsBindC() const { return (flags_ & BIND_C) != 0; }
- bool IsNontrivial() const { return (flags_ & NONTRIVIAL) != 0; }
-
- bool IsSameType(const DerivedType &) const;
-
- void Initialize(char *instance) const;
- void Destroy(char *instance, bool finalize = true) const;
-
-private:
- enum Flag { SEQUENCE = 1, BIND_C = 2, NONTRIVIAL = 4 };
-
- // True when any descriptor of data of this derived type will require
- // an addendum pointing to a DerivedType, possibly with values of
- // LEN type parameters. Conservative.
- bool IsNontrivialAnalysis() const;
-
- const char *name_{""}; // NUL-terminated constant text
- std::size_t kindParameters_{0};
- std::size_t lenParameters_{0};
- const TypeParameter *typeParameter_{nullptr}; // array
- std::size_t components_{0}; // *not* including type parameters
- const Component *component_{nullptr}; // array
- std::size_t typeBoundProcedures_{0};
- const TypeBoundProcedure *typeBoundProcedure_{nullptr}; // array
- std::uint64_t flags_{0};
- std::size_t bytes_{0};
-};
-} // namespace Fortran::runtime
-#endif // FORTRAN_RUNTIME_DERIVED_TYPE_H_
diff --git a/flang/runtime/derived.cpp b/flang/runtime/derived.cpp
new file mode 100644
index 000000000000..db743ba3a1be
--- /dev/null
+++ b/flang/runtime/derived.cpp
@@ -0,0 +1,123 @@
+//===-- runtime/derived.cpp -----------------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "derived.h"
+#include "descriptor.h"
+#include "type-info.h"
+
+namespace Fortran::runtime {
+
+static const typeInfo::SpecialBinding *FindFinal(
+ const typeInfo::DerivedType &derived, int rank) {
+ const typeInfo::SpecialBinding *elemental{nullptr};
+ const Descriptor &specialDesc{derived.special.descriptor()};
+ std::size_t totalSpecialBindings{specialDesc.Elements()};
+ for (std::size_t j{0}; j < totalSpecialBindings; ++j) {
+ const auto &special{
+ *specialDesc.ZeroBasedIndexedElement<typeInfo::SpecialBinding>(j)};
+ switch (special.which) {
+ case typeInfo::SpecialBinding::Which::Final:
+ if (special.rank == rank) {
+ return &special;
+ }
+ break;
+ case typeInfo::SpecialBinding::Which::ElementalFinal:
+ elemental = &special;
+ break;
+ case typeInfo::SpecialBinding::Which::AssumedRankFinal:
+ return &special;
+ default:;
+ }
+ }
+ return elemental;
+}
+
+static void CallFinalSubroutine(
+ const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
+ if (const auto *special{FindFinal(derived, descriptor.rank())}) {
+ if (special->which == typeInfo::SpecialBinding::Which::ElementalFinal) {
+ std::size_t byteStride{descriptor.ElementBytes()};
+ auto p{reinterpret_cast<void (*)(char *)>(special->proc)};
+ // Finalizable objects must be contiguous.
+ std::size_t elements{descriptor.Elements()};
+ for (std::size_t j{0}; j < elements; ++j) {
+ p(descriptor.OffsetElement<char>(j * byteStride));
+ }
+ } else if (special->isArgDescriptorSet & 1) {
+ auto p{reinterpret_cast<void (*)(const Descriptor &)>(special->proc)};
+ p(descriptor);
+ } else {
+ // Finalizable objects must be contiguous.
+ auto p{reinterpret_cast<void (*)(char *)>(special->proc)};
+ p(descriptor.OffsetElement<char>());
+ }
+ }
+}
+
+static inline SubscriptValue GetValue(
+ const typeInfo::Value &value, const Descriptor &descriptor) {
+ if (value.genre == typeInfo::Value::Genre::LenParameter) {
+ return descriptor.Addendum()->LenParameterValue(value.value);
+ } else {
+ return value.value;
+ }
+}
+
+// The order of finalization follows Fortran 2018 7.5.6.2, with
+// deallocation of non-parent components (and their consequent finalization)
+// taking place before parent component finalization.
+void Destroy(const Descriptor &descriptor, bool finalize,
+ const typeInfo::DerivedType &derived) {
+ if (finalize) {
+ CallFinalSubroutine(descriptor, derived);
+ }
+ const Descriptor &componentDesc{derived.component.descriptor()};
+ std::int64_t myComponents{componentDesc.GetDimension(0).Extent()};
+ std::size_t elements{descriptor.Elements()};
+ std::size_t byteStride{descriptor.ElementBytes()};
+ for (unsigned k{0}; k < myComponents; ++k) {
+ const auto &comp{
+ *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
+ if (comp.genre == typeInfo::Component::Genre::Allocatable ||
+ comp.genre == typeInfo::Component::Genre::Automatic) {
+ for (std::size_t j{0}; j < elements; ++j) {
+ descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset)
+ ->Deallocate(finalize);
+ }
+ } else if (comp.genre == typeInfo::Component::Genre::Data &&
+ comp.derivedType.descriptor().raw().base_addr) {
+ SubscriptValue extent[maxRank];
+ const Descriptor &boundsDesc{comp.bounds.descriptor()};
+ for (int dim{0}; dim < comp.rank; ++dim) {
+ extent[dim] =
+ GetValue(
+ *boundsDesc.ZeroBasedIndexedElement<typeInfo::Value>(2 * dim),
+ descriptor) -
+ GetValue(*boundsDesc.ZeroBasedIndexedElement<typeInfo::Value>(
+ 2 * dim + 1),
+ descriptor) +
+ 1;
+ }
+ StaticDescriptor<maxRank, true, 0> staticDescriptor;
+ Descriptor &compDesc{staticDescriptor.descriptor()};
+ const auto &compType{*comp.derivedType.descriptor()
+ .OffsetElement<typeInfo::DerivedType>()};
+ for (std::size_t j{0}; j < elements; ++j) {
+ compDesc.Establish(compType,
+ descriptor.OffsetElement<char>(j * byteStride + comp.offset),
+ comp.rank, extent);
+ Destroy(compDesc, finalize, compType);
+ }
+ }
+ }
+ const Descriptor &parentDesc{derived.parent.descriptor()};
+ if (const auto *parent{parentDesc.OffsetElement<typeInfo::DerivedType>()}) {
+ Destroy(descriptor, finalize, *parent);
+ }
+}
+} // namespace Fortran::runtime
diff --git a/flang/runtime/derived.h b/flang/runtime/derived.h
new file mode 100644
index 000000000000..314c05772670
--- /dev/null
+++ b/flang/runtime/derived.h
@@ -0,0 +1,20 @@
+//===-- runtime/derived.h -------------------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FLANG_RUNTIME_DERIVED_H_
+#define FLANG_RUNTIME_DERIVED_H_
+
+namespace Fortran::runtime::typeInfo {
+class DerivedType;
+}
+
+namespace Fortran::runtime {
+class Descriptor;
+void Destroy(const Descriptor &, bool finalize, const typeInfo::DerivedType &);
+} // namespace Fortran::runtime
+#endif // FLANG_RUNTIME_FINAL_H_
diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp
index 94d081038c9b..efcd61b50c4f 100644
--- a/flang/runtime/descriptor.cpp
+++ b/flang/runtime/descriptor.cpp
@@ -7,8 +7,10 @@
//===----------------------------------------------------------------------===//
#include "descriptor.h"
+#include "derived.h"
#include "memory.h"
#include "terminator.h"
+#include "type-info.h"
#include <cassert>
#include <cstdlib>
#include <cstring>
@@ -54,10 +56,9 @@ void Descriptor::Establish(int characterKind, std::size_t characters, void *p,
characterKind * characters, p, rank, extent, attribute, addendum);
}
-void Descriptor::Establish(const DerivedType &dt, void *p, int rank,
+void Descriptor::Establish(const typeInfo::DerivedType &dt, void *p, int rank,
const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
- Establish(
- CFI_type_struct, dt.SizeInBytes(), p, rank, extent, attribute, true);
+ Establish(CFI_type_struct, dt.sizeInBytes, p, rank, extent, attribute, true);
DescriptorAddendum *a{Addendum()};
Terminator terminator{__FILE__, __LINE__};
RUNTIME_CHECK(terminator, a != nullptr);
@@ -88,10 +89,11 @@ OwningPtr<Descriptor> Descriptor::Create(int characterKind,
characterKind * characters, p, rank, extent, attribute);
}
-OwningPtr<Descriptor> Descriptor::Create(const DerivedType &dt, void *p,
- int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
- return Create(TypeCode{CFI_type_struct}, dt.SizeInBytes(), p, rank, extent,
- attribute, dt.lenParameters());
+OwningPtr<Descriptor> Descriptor::Create(const typeInfo::DerivedType &dt,
+ void *p, int rank, const SubscriptValue *extent,
+ ISO::CFI_attribute_t attribute) {
+ return Create(TypeCode{CFI_type_struct}, dt.sizeInBytes, p, rank, extent,
+ attribute, dt.LenParameters());
}
std::size_t Descriptor::SizeInBytes() const {
@@ -138,25 +140,17 @@ int Descriptor::Allocate(const SubscriptValue lb[], const SubscriptValue ub[]) {
}
int Descriptor::Deallocate(bool finalize) {
- if (raw_.base_addr) {
- Destroy(static_cast<char *>(raw_.base_addr), finalize);
- }
+ Destroy(finalize);
return ISO::CFI_deallocate(&raw_);
}
-void Descriptor::Destroy(char *data, bool finalize) const {
- if (data) {
- if (const DescriptorAddendum * addendum{Addendum()}) {
+void Descriptor::Destroy(bool finalize) const {
+ if (const DescriptorAddendum * addendum{Addendum()}) {
+ if (const typeInfo::DerivedType * dt{addendum->derivedType()}) {
if (addendum->flags() & DescriptorAddendum::DoNotFinalize) {
finalize = false;
}
- if (const DerivedType * dt{addendum->derivedType()}) {
- std::size_t elements{Elements()};
- std::size_t elementBytes{ElementBytes()};
- for (std::size_t j{0}; j < elements; ++j) {
- dt->Destroy(data + j * elementBytes, finalize);
- }
- }
+ runtime::Destroy(*this, finalize, *dt);
}
}
}
@@ -254,6 +248,11 @@ std::size_t DescriptorAddendum::SizeInBytes() const {
return SizeInBytes(LenParameters());
}
+std::size_t DescriptorAddendum::LenParameters() const {
+ const auto *type{derivedType()};
+ return type ? type->LenParameters() : 0;
+}
+
void DescriptorAddendum::Dump(FILE *f) const {
std::fprintf(
f, " derivedType @ %p\n", reinterpret_cast<const void *>(derivedType_));
diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h
index 28ac0d30db4a..c83933056931 100644
--- a/flang/runtime/descriptor.h
+++ b/flang/runtime/descriptor.h
@@ -18,7 +18,6 @@
// User C code is welcome to depend on that ISO_Fortran_binding.h file,
// but should never reference this internal header.
-#include "derived-type.h"
#include "memory.h"
#include "type-code.h"
#include "flang/ISO_Fortran_binding.h"
@@ -28,6 +27,11 @@
#include <cstdio>
#include <cstring>
+namespace Fortran::runtime::typeInfo {
+using TypeParameterValue = std::int64_t;
+class DerivedType;
+} // namespace Fortran::runtime::typeInfo
+
namespace Fortran::runtime {
using SubscriptValue = ISO::CFI_index_t;
@@ -63,7 +67,7 @@ class Dimension {
// descriptors serve as POINTER and ALLOCATABLE components of derived type
// instances. The presence of this structure is implied by the flag
// CFI_cdesc_t.f18Addendum, and the number of elements in the len_[]
-// array is determined by DerivedType::lenParameters().
+// array is determined by derivedType_->LenParameters().
class DescriptorAddendum {
public:
enum Flags {
@@ -74,41 +78,38 @@ class DescriptorAddendum {
};
explicit DescriptorAddendum(
- const DerivedType *dt = nullptr, std::uint64_t flags = 0)
+ const typeInfo::DerivedType *dt = nullptr, std::uint64_t flags = 0)
: derivedType_{dt}, flags_{flags} {}
- const DerivedType *derivedType() const { return derivedType_; }
- DescriptorAddendum &set_derivedType(const DerivedType *dt) {
+ const typeInfo::DerivedType *derivedType() const { return derivedType_; }
+ DescriptorAddendum &set_derivedType(const typeInfo::DerivedType *dt) {
derivedType_ = dt;
return *this;
}
std::uint64_t &flags() { return flags_; }
const std::uint64_t &flags() const { return flags_; }
- std::size_t LenParameters() const {
- if (derivedType_) {
- return derivedType_->lenParameters();
- }
- return 0;
- }
+ std::size_t LenParameters() const;
- TypeParameterValue LenParameterValue(int which) const { return len_[which]; }
+ typeInfo::TypeParameterValue LenParameterValue(int which) const {
+ return len_[which];
+ }
static constexpr std::size_t SizeInBytes(int lenParameters) {
- return sizeof(DescriptorAddendum) - sizeof(TypeParameterValue) +
- lenParameters * sizeof(TypeParameterValue);
+ return sizeof(DescriptorAddendum) - sizeof(typeInfo::TypeParameterValue) +
+ lenParameters * sizeof(typeInfo::TypeParameterValue);
}
std::size_t SizeInBytes() const;
- void SetLenParameterValue(int which, TypeParameterValue x) {
+ void SetLenParameterValue(int which, typeInfo::TypeParameterValue x) {
len_[which] = x;
}
void Dump(FILE * = stdout) const;
private:
- const DerivedType *derivedType_{nullptr};
+ const typeInfo::DerivedType *derivedType_;
std::uint64_t flags_{0};
- TypeParameterValue len_[1]; // must be the last component
+ typeInfo::TypeParameterValue len_[1]; // must be the last component
// The LEN type parameter values can also include captured values of
// specification expressions that were used for bounds and for LEN type
// parameters of components. The values have been truncated to the LEN
@@ -155,8 +156,8 @@ class Descriptor {
int rank = maxRank, const SubscriptValue *extent = nullptr,
ISO::CFI_attribute_t attribute = CFI_attribute_other,
bool addendum = false);
- void Establish(const DerivedType &dt, void *p = nullptr, int rank = maxRank,
- const SubscriptValue *extent = nullptr,
+ void Establish(const typeInfo::DerivedType &dt, void *p = nullptr,
+ int rank = maxRank, const SubscriptValue *extent = nullptr,
ISO::CFI_attribute_t attribute = CFI_attribute_other);
static OwningPtr<Descriptor> Create(TypeCode t, std::size_t elementBytes,
@@ -171,8 +172,9 @@ class Descriptor {
SubscriptValue characters, void *p = nullptr, int rank = maxRank,
const SubscriptValue *extent = nullptr,
ISO::CFI_attribute_t attribute = CFI_attribute_other);
- static OwningPtr<Descriptor> Create(const DerivedType &dt, void *p = nullptr,
- int rank = maxRank, const SubscriptValue *extent = nullptr,
+ static OwningPtr<Descriptor> Create(const typeInfo::DerivedType &dt,
+ void *p = nullptr, int rank = maxRank,
+ const SubscriptValue *extent = nullptr,
ISO::CFI_attribute_t attribute = CFI_attribute_other);
ISO::CFI_cdesc_t &raw() { return raw_; }
@@ -284,7 +286,7 @@ class Descriptor {
int Allocate();
int Allocate(const SubscriptValue lb[], const SubscriptValue ub[]);
int Deallocate(bool finalize = true);
- void Destroy(char *data, bool finalize = true) const;
+ void Destroy(bool finalize = true) const;
bool IsContiguous(int leadingDimensions = maxRank) const {
auto bytes{static_cast<SubscriptValue>(ElementBytes())};
@@ -341,11 +343,7 @@ class alignas(Descriptor) StaticDescriptor {
assert(descriptor().SizeInBytes() <= byteSize);
if (DescriptorAddendum * addendum{descriptor().Addendum()}) {
assert(hasAddendum);
- if (const DerivedType * dt{addendum->derivedType()}) {
- assert(dt->lenParameters() <= maxLengthTypeParameters);
- } else {
- assert(maxLengthTypeParameters == 0);
- }
+ assert(addendum->LenParameters() <= maxLengthTypeParameters);
} else {
assert(!hasAddendum);
assert(maxLengthTypeParameters == 0);
diff --git a/flang/runtime/transformational.cpp b/flang/runtime/transformational.cpp
index 69de8ffc57ab..cd5c7d81da4d 100644
--- a/flang/runtime/transformational.cpp
+++ b/flang/runtime/transformational.cpp
@@ -90,7 +90,7 @@ OwningPtr<Descriptor> RESHAPE(const Descriptor &source, const Descriptor &shape,
// Create and populate the result's descriptor.
const DescriptorAddendum *sourceAddendum{source.Addendum()};
- const DerivedType *sourceDerivedType{
+ const typeInfo::DerivedType *sourceDerivedType{
sourceAddendum ? sourceAddendum->derivedType() : nullptr};
OwningPtr<Descriptor> result;
if (sourceDerivedType) {
@@ -105,7 +105,7 @@ OwningPtr<Descriptor> RESHAPE(const Descriptor &source, const Descriptor &shape,
RUNTIME_CHECK(terminator, resultAddendum);
resultAddendum->flags() |= DescriptorAddendum::DoNotFinalize;
if (sourceDerivedType) {
- std::size_t lenParameters{sourceDerivedType->lenParameters()};
+ std::size_t lenParameters{sourceAddendum->LenParameters()};
for (std::size_t j{0}; j < lenParameters; ++j) {
resultAddendum->SetLenParameterValue(
j, sourceAddendum->LenParameterValue(j));
diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h
new file mode 100644
index 000000000000..4f933e8bb5a5
--- /dev/null
+++ b/flang/runtime/type-info.h
@@ -0,0 +1,161 @@
+//===-- runtime/type-info.h -------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_RUNTIME_TYPE_INFO_H_
+#define FORTRAN_RUNTIME_TYPE_INFO_H_
+
+// A C++ perspective of the derived type description schemata in
+// flang/module/__fortran_type_info.f90.
+
+#include "descriptor.h"
+#include "flang/Common/Fortran.h"
+#include <cinttypes>
+#include <memory>
+
+namespace Fortran::runtime::typeInfo {
+
+class DerivedType {
+public:
+ ~DerivedType();
+
+ // This member comes first because it's used like a vtable by generated code.
+ // It includes all of the ancestor types' bindings, if any, first,
+ // with any overrides from descendants already applied to them. Local
+ // bindings then follow in alphabetic order of binding name.
+ StaticDescriptor<1> binding; // TYPE(BINDING), DIMENSION(:), POINTER
+
+ StaticDescriptor<0> name; // CHARACTER(:), POINTER
+
+ std::uint64_t sizeInBytes{0};
+ StaticDescriptor<0> parent; // TYPE(DERIVEDTYPE), POINTER
+
+ // Instantiations of a parameterized derived type with KIND type
+ // parameters will point this data member to the description of
+ // the original uninstantiated type, which may be shared from a
+ // module via use association. The original uninstantiated derived
+ // type description will point to itself. Derived types that have
+ // no KIND type parameters will have a null pointer here.
+ StaticDescriptor<0> uninstantiated; // TYPE(DERIVEDTYPE), POINTER
+
+ // TODO: flags for SEQUENCE, BIND(C), any PRIVATE component(? see 7.5.2)
+ std::uint64_t typeHash{0};
+
+ // These pointer targets include all of the items from the parent, if any.
+ StaticDescriptor<1> kindParameter; // pointer to rank-1 array of INTEGER(8)
+ StaticDescriptor<1> lenParameterKind; // pointer to rank-1 array of INTEGER(1)
+
+ // This array of local data components includes the parent component.
+ // Components are in alphabetic order.
+ // It does not include procedure pointer components.
+ StaticDescriptor<1, true> component; // TYPE(COMPONENT), POINTER, DIMENSION(:)
+
+ // Procedure pointer components
+ StaticDescriptor<1, true> procPtr; // TYPE(PROCPTR), POINTER, DIMENSION(:)
+
+ // Does not include special bindings from ancestral types.
+ StaticDescriptor<1, true>
+ special; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:)
+
+ std::size_t LenParameters() const {
+ return lenParameterKind.descriptor().Elements();
+ }
+};
+
+using ProcedurePointer = void (*)(); // TYPE(C_FUNPTR)
+
+struct Binding {
+ ProcedurePointer proc;
+ StaticDescriptor<0> name; // CHARACTER(:), POINTER
+};
+
+struct Value {
+ enum class Genre : std::uint8_t {
+ Deferred = 1,
+ Explicit = 2,
+ LenParameter = 3
+ };
+ Genre genre{Genre::Explicit};
+ // The value encodes an index into the table of LEN type parameters in
+ // a descriptor's addendum for genre == Genre::LenParameter.
+ TypeParameterValue value{0};
+};
+
+struct Component {
+ enum class Genre : std::uint8_t { Data, Pointer, Allocatable, Automatic };
+ StaticDescriptor<0> name; // CHARACTER(:), POINTER
+ Genre genre{Genre::Data};
+ std::uint8_t category; // common::TypeCategory
+ std::uint8_t kind{0};
+ std::uint8_t rank{0};
+ std::uint64_t offset{0};
+ Value characterLen; // for TypeCategory::Character
+ StaticDescriptor<0, true> derivedType; // TYPE(DERIVEDTYPE), POINTER
+ StaticDescriptor<1, true> lenValue; // TYPE(VALUE), POINTER, DIMENSION(:)
+ StaticDescriptor<2, true> bounds; // TYPE(VALUE), POINTER, DIMENSION(2,:)
+ char *initialization{nullptr}; // for Genre::Data and Pointer
+ // TODO: cobounds
+ // TODO: `PRIVATE` attribute
+};
+
+struct ProcPtrComponent {
+ StaticDescriptor<0> name; // CHARACTER(:), POINTER
+ std::uint64_t offset{0};
+ ProcedurePointer procInitialization; // for Genre::Procedure
+};
+
+struct SpecialBinding {
+ enum class Which : std::uint8_t {
+ None = 0,
+ Assignment = 4,
+ ElementalAssignment = 5,
+ Final = 8,
+ ElementalFinal = 9,
+ AssumedRankFinal = 10,
+ ReadFormatted = 16,
+ ReadUnformatted = 17,
+ WriteFormatted = 18,
+ WriteUnformatted = 19
+ } which{Which::None};
+
+ // Used for Which::Final only. Which::Assignment always has rank 0, as
+ // type-bound defined assignment for rank > 0 must be elemental
+ // due to the required passed object dummy argument, which are scalar.
+ // User defined derived type I/O is always scalar.
+ std::uint8_t rank{0};
+
+ // The following little bit-set identifies which dummy arguments are
+ // passed via descriptors for their derived type arguments.
+ // Which::Assignment and Which::ElementalAssignment:
+ // Set to 1, 2, or (usually 3).
+ // The passed-object argument (usually the "to") is always passed via a
+ // a descriptor in the cases where the runtime will call a defined
+ // assignment because these calls are to type-bound generics,
+ // not generic interfaces, and type-bound generic defined assigment
+ // may appear only in an extensible type and requires a passed-object
+ // argument (see C774), and passed-object arguments to TBPs must be
+ // both polymorphic and scalar (C760). The non-passed-object argument
+ // (usually the "from") is usually, but not always, also a descriptor.
+ // Which::Final and Which::ElementalFinal:
+ // Set to 1 when dummy argument is assumed-shape; otherwise, the
+ // argument can be passed by address. (Fortran guarantees that
+ // any finalized object must be whole and contiguous by restricting
+ // the use of DEALLOCATE on pointers. The dummy argument of an
+ // elemental final subroutine must be scalar and monomorphic, but
+ // use a descriptors when the type has LEN parameters.)
+ // Which::AssumedRankFinal: flag must necessarily be set
+ // User derived type I/O:
+ // Set to 1 when "dtv" initial dummy argument is polymorphic, which is
+ // the case when and only when the derived type is extensible.
+ // When false, the user derived type I/O subroutine must have been
+ // called via a generic interface, not a generic TBP.
+ std::uint8_t isArgDescriptorSet{0};
+
+ ProcedurePointer proc{nullptr};
+};
+} // namespace Fortran::runtime::typeInfo
+#endif // FORTRAN_RUNTIME_TYPE_INFO_H_
diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90
new file mode 100644
index 000000000000..e29cb022128a
--- /dev/null
+++ b/flang/test/Semantics/typeinfo01.f90
@@ -0,0 +1,239 @@
+!RUN: %f18 -fdebug-dump-symbols -fparse-only %s | FileCheck %s
+! Tests for derived type runtime descriptions
+
+module m01
+ type :: t1
+ integer :: n
+ end type
+!CHECK: .c.t1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.n,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
+!CHECK: .dt.t1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t1,sizeinbytes=4_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t1,procptr=NULL(),special=NULL())
+!CHECK: .n.n, SAVE, TARGET: ObjectEntity type: CHARACTER(2_8,1) init:"n"
+!CHECK: .n.t1, SAVE, TARGET: ObjectEntity type: CHARACTER(2_8,1) init:"t1"
+end module
+
+module m02
+ type :: parent
+ integer :: pn
+ end type
+ type, extends(parent) :: child
+ integer :: cn
+ end type
+!CHECK: .c.child, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:1_8 init:[component::component(name=.n.cn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=4_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.parent,genre=1_1,category=5_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.parent,lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
+!CHECK: .c.parent, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.pn,genre=1_1,category=0_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
+!CHECK: .dt.child, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.child,sizeinbytes=8_8,parent=.dt.parent,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.child,procptr=NULL(),special=NULL())
+!CHECK: .dt.parent, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.parent,sizeinbytes=4_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.parent,procptr=NULL(),special=NULL())
+end module
+
+module m03
+ type :: kpdt(k)
+ integer(kind=1), kind :: k = 1
+ real(kind=k) :: a
+ end type
+ type(kpdt(4)) :: x
+!CHECK: .c.kpdt.0, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.a,genre=1_1,category=1_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
+!CHECK: .dt.kpdt, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.kpdt,parent=NULL(),uninstantiated=NULL(),kindparameter=.kp.kpdt,lenparameterkind=NULL())
+!CHECK: .dt.kpdt.0, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,parent=NULL(),uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.0,lenparameterkind=NULL(),component=.c.kpdt.0,procptr=NULL(),special=NULL())
+!CHECK: .kp.kpdt, SAVE, TARGET: ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::1_8]
+!CHECK: .kp.kpdt.0, SAVE, TARGET: ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::4_8]
+end module
+
+module m04
+ type :: tbps
+ contains
+ procedure :: b2 => s1
+ procedure :: b1 => s1
+ end type
+ contains
+ subroutine s1(x)
+ class(tbps), intent(in) :: x
+ end subroutine
+!CHECK: .dt.tbps, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.tbps,name=.n.tbps,sizeinbytes=0_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=NULL())
+!CHECK: .v.tbps, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:1_8 init:[binding::binding(proc=s1,name=.n.b1),binding(proc=s1,name=.n.b2)]
+end module
+
+module m05
+ type :: t
+ procedure(s1), pointer :: p1 => s1
+ end type
+ contains
+ subroutine s1(x)
+ class(t), intent(in) :: x
+ end subroutine
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=.p.t,special=NULL())
+!CHECK: .p.t, SAVE, TARGET: ObjectEntity type: TYPE(procptrcomponent) shape: 0_8:0_8 init:[procptrcomponent::procptrcomponent(name=.n.p1,offset=0_8,initialization=s1)]
+end module
+
+module m06
+ type :: t
+ contains
+ procedure :: s1
+ generic :: assignment(=) => s1
+ end type
+ type, extends(t) :: t2
+ contains
+ procedure :: s1 => s2 ! override
+ end type
+ contains
+ subroutine s1(x, y)
+ class(t), intent(out) :: x
+ class(t), intent(in) :: y
+ end subroutine
+ subroutine s2(x, y)
+ class(t2), intent(out) :: x
+ class(t), intent(in) :: y
+ end subroutine
+!CHECK: .c.t2, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.t,genre=1_1,category=5_1,kind=0_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=.dt.t,lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t)
+!CHECK: .dt.t2, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t2,name=.n.t2,sizeinbytes=0_8,parent=.dt.t,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=.c.t2,procptr=NULL(),special=NULL())
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=4_1,rank=0_1,isargdescriptorset=3_1,proc=s1)]
+!CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)]
+!CHECK: .v.t2, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s2,name=.n.s1)]
+end module
+
+module m07
+ type :: t
+ contains
+ procedure :: s1
+ generic :: assignment(=) => s1
+ end type
+ contains
+ impure elemental subroutine s1(x, y)
+ class(t), intent(out) :: x
+ class(t), intent(in) :: y
+ end subroutine
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:0_8 init:[specialbinding::specialbinding(which=5_1,rank=0_1,isargdescriptorset=3_1,proc=s1)]
+!CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:0_8 init:[binding::binding(proc=s1,name=.n.s1)]
+end module
+
+module m08
+ type :: t
+ contains
+ final :: s1, s2, s3
+ end type
+ contains
+ subroutine s1(x)
+ type(t) :: x(:)
+ end subroutine
+ subroutine s2(x)
+ type(t) :: x(3,3)
+ end subroutine
+ impure elemental subroutine s3(x)
+ type(t) :: x
+ end subroutine
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=8_1,rank=1_1,isargdescriptorset=1_1,proc=s1),specialbinding(which=8_1,rank=2_1,isargdescriptorset=0_1,proc=s2),specialbinding(which=9_1,rank=0_1,isargdescriptorset=0_1,proc=s3)]
+end module
+
+module m09
+ type :: t
+ contains
+ procedure :: rf, ru, wf, wu
+ generic :: read(formatted) => rf
+ generic :: read(unformatted) => ru
+ generic :: write(formatted) => wf
+ generic :: write(unformatted) => wu
+ end type
+ contains
+ subroutine rf(x,u,iot,v,iostat,iomsg)
+ class(t), intent(inout) :: x
+ integer, intent(in) :: u
+ character(len=*), intent(in) :: iot
+ integer, intent(in) :: v(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end subroutine
+ subroutine ru(x,u,iostat,iomsg)
+ class(t), intent(inout) :: x
+ integer, intent(in) :: u
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end subroutine
+ subroutine wf(x,u,iot,v,iostat,iomsg)
+ class(t), intent(in) :: x
+ integer, intent(in) :: u
+ character(len=*), intent(in) :: iot
+ integer, intent(in) :: v(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end subroutine
+ subroutine wu(x,u,iostat,iomsg)
+ class(t), intent(in) :: x
+ integer, intent(in) :: u
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end subroutine
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=.v.t,name=.n.t,sizeinbytes=0_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=16_1,rank=0_1,isargdescriptorset=1_1,proc=rf),specialbinding(which=17_1,rank=0_1,isargdescriptorset=1_1,proc=ru),specialbinding(which=18_1,rank=0_1,isargdescriptorset=1_1,proc=wf),specialbinding(which=19_1,rank=0_1,isargdescriptorset=1_1,proc=wu)]
+!CHECK: .v.t, SAVE, TARGET: ObjectEntity type: TYPE(binding) shape: 0_8:3_8 init:[binding::binding(proc=rf,name=.n.rf),binding(proc=ru,name=.n.ru),binding(proc=wf,name=.n.wf),binding(proc=wu,name=.n.wu)]
+end module
+
+module m10
+ type :: t
+ end type
+ interface read(formatted)
+ procedure :: rf
+ end interface
+ interface read(unformatted)
+ procedure :: ru
+ end interface
+ interface write(formatted)
+ procedure ::wf
+ end interface
+ interface write(unformatted)
+ procedure :: wu
+ end interface
+ contains
+ subroutine rf(x,u,iot,v,iostat,iomsg)
+ type(t), intent(inout) :: x
+ integer, intent(in) :: u
+ character(len=*), intent(in) :: iot
+ integer, intent(in) :: v(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end subroutine
+ subroutine ru(x,u,iostat,iomsg)
+ type(t), intent(inout) :: x
+ integer, intent(in) :: u
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end subroutine
+ subroutine wf(x,u,iot,v,iostat,iomsg)
+ type(t), intent(in) :: x
+ integer, intent(in) :: u
+ character(len=*), intent(in) :: iot
+ integer, intent(in) :: v(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end subroutine
+ subroutine wu(x,u,iostat,iomsg)
+ type(t), intent(in) :: x
+ integer, intent(in) :: u
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end subroutine
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t)
+!CHECK: .s.t, SAVE, TARGET: ObjectEntity type: TYPE(specialbinding) shape: 0_8:3_8 init:[specialbinding::specialbinding(which=16_1,rank=0_1,isargdescriptorset=0_1,proc=rf),specialbinding(which=17_1,rank=0_1,isargdescriptorset=0_1,proc=ru),specialbinding(which=18_1,rank=0_1,isargdescriptorset=0_1,proc=wf),specialbinding(which=19_1,rank=0_1,isargdescriptorset=0_1,proc=wu)]
+end module
+
+module m11
+ real, target :: target
+ type :: t(len)
+ integer(kind=8), len :: len
+ real, allocatable :: allocatable(:)
+ real, pointer :: pointer => target
+ character(len=len) :: chauto
+ real :: automatic(len)
+ end type
+!CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.t)
+!CHECK: .lpk.t, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1]
+ contains
+ subroutine s1(x)
+!CHECK: .b.t.1.allocatable, SAVE, TARGET: ObjectEntity type: TYPE(value) shape: 0_8:1_8,0_8:0_8 init:reshape([value::value(genre=1_1,value=0_8),value(genre=1_1,value=0_8)],shape=[2,1])
+!CHECK: .b.t.1.automatic, SAVE, TARGET: ObjectEntity type: TYPE(value) shape: 0_8:1_8,0_8:0_8 init:reshape([value::value(genre=2_1,value=1_8),value(genre=3_1,value=0_8)],shape=[2,1])
+!CHECK: .c.t.1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:3_8 init:[component::component(name=.n.allocatable,genre=3_1,category=1_1,kind=4_1,rank=1_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.allocatable,initialization=NULL()),component(name=.n.automatic,genre=4_1,category=1_1,kind=4_1,rank=1_1,offset=96_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.automatic,initialization=NULL()),component(name=.n.chauto,genre=4_1,category=3_1,kind=1_1,rank=0_1,offset=72_8,characterlen=value(genre=3_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.pointer,genre=2_1,category=1_1,kind=4_1,rank=0_1,offset=48_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=target)]
+!CHECK: .dt.t.1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,parent=NULL(),uninstantiated=.dt.t,kindparameter=NULL(),lenparameterkind=.lpk.t.1,component=.c.t.1,procptr=NULL(),special=NULL())
+!CHECK: .lpk.t.1, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1]
+ type(t(*)), intent(in) :: x
+ end subroutine
+end module
diff --git a/flang/tools/f18/CMakeLists.txt b/flang/tools/f18/CMakeLists.txt
index 64ccf12505fe..cdc09fc7a68a 100644
--- a/flang/tools/f18/CMakeLists.txt
+++ b/flang/tools/f18/CMakeLists.txt
@@ -18,6 +18,8 @@ target_link_libraries(f18
)
set(MODULES
+ "__fortran_builtins"
+ "__fortran_type_info"
"ieee_arithmetic"
"ieee_exceptions"
"ieee_features"
@@ -25,6 +27,7 @@ set(MODULES
"iso_fortran_env"
"omp_lib"
"__fortran_builtins"
+ "__fortran_type_info"
)
set(include ${FLANG_BINARY_DIR}/include/flang)
@@ -35,8 +38,10 @@ target_include_directories(f18
# Create module files directly from the top-level module source directory
foreach(filename ${MODULES})
- if(${filename} MATCHES "__fortran_builtins")
+ if(${filename} MATCHES "__fortran_type_info")
set(depends "")
+ elseif(${filename} MATCHES "__fortran_builtins")
+ set(depends ${include}/__fortran_type_info.mod)
else()
set(depends ${include}/__fortran_builtins.mod)
endif()
diff --git a/flang/tools/f18/f18.cpp b/flang/tools/f18/f18.cpp
index 918bb6accef8..895e61ecd5e3 100644
--- a/flang/tools/f18/f18.cpp
+++ b/flang/tools/f18/f18.cpp
@@ -22,6 +22,7 @@
#include "flang/Parser/provenance.h"
#include "flang/Parser/unparse.h"
#include "flang/Semantics/expression.h"
+#include "flang/Semantics/runtime-type-info.h"
#include "flang/Semantics/semantics.h"
#include "flang/Semantics/unparse-with-symbols.h"
#include "llvm/Support/Errno.h"
@@ -253,10 +254,10 @@ std::string CompileFortran(std::string path, Fortran::parser::Options options,
parsing.cooked().AsCharBlock(), driver.debugModuleWriter};
semantics.Perform();
semantics.EmitMessages(llvm::errs());
- if (driver.dumpSymbols) {
- semantics.DumpSymbols(llvm::outs());
- }
if (semantics.AnyFatalError()) {
+ if (driver.dumpSymbols) {
+ semantics.DumpSymbols(llvm::outs());
+ }
llvm::errs() << driver.prefix << "semantic errors in " << path << '\n';
exitStatus = EXIT_FAILURE;
if (driver.dumpParseTree) {
@@ -264,6 +265,15 @@ std::string CompileFortran(std::string path, Fortran::parser::Options options,
}
return {};
}
+ auto tables{
+ Fortran::semantics::BuildRuntimeDerivedTypeTables(semanticsContext)};
+ if (!tables.schemata) {
+ llvm::errs() << driver.prefix
+ << "could not find module file for __fortran_type_info\n";
+ }
+ if (driver.dumpSymbols) {
+ semantics.DumpSymbols(llvm::outs());
+ }
if (driver.dumpUnparseWithSymbols) {
Fortran::semantics::UnparseWithSymbols(
llvm::outs(), parseTree, driver.encoding);
More information about the llvm-branch-commits
mailing list