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
--- /dev/null
+//===-- 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_
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
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_;
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().
resolve-names-utils.cpp
resolve-names.cpp
rewrite-parse-tree.cpp
+ runtime-type-info.cpp
scope.cpp
semantics.cpp
symbol.cpp
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_) {
}
}
scope.set_size(offset_);
- scope.set_alignment(alignment_);
+ scope.SetAlignment(alignment_);
// Assign offsets in COMMON blocks.
for (auto &pair : scope.commonBlocks()) {
DoCommonBlock(*pair.second);
}
} 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");
--- /dev/null
+//===-- 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
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();
} 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;
}
}
}
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;
}
! 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
--- /dev/null
+!===-- 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
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
buffer.cpp
character.cpp
connection.cpp
- derived-type.cpp
+ derived.cpp
descriptor.cpp
edit-input.cpp
edit-output.cpp
}
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);
#include "descriptor.h"
#include "entry-names.h"
+namespace Fortran::runtime::typeInfo {
+class DerivedType;
+}
+
namespace Fortran::runtime {
extern "C" {
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
+++ /dev/null
-//===-- 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
+++ /dev/null
-//===-- 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_
--- /dev/null
+//===-- 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
--- /dev/null
+//===-- 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_
//===----------------------------------------------------------------------===//
#include "descriptor.h"
+#include "derived.h"
#include "memory.h"
#include "terminator.h"
+#include "type-info.h"
#include <cassert>
#include <cstdlib>
#include <cstring>
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);
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 {
}
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);
}
}
}
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_));
// 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"
#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;
// 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 {
};
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
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,
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_; }
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())};
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);
// 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) {
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));
--- /dev/null
+//===-- 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_
--- /dev/null
+!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
)
set(MODULES
+ "__fortran_builtins"
+ "__fortran_type_info"
"ieee_arithmetic"
"ieee_exceptions"
"ieee_features"
"iso_fortran_env"
"omp_lib"
"__fortran_builtins"
+ "__fortran_type_info"
)
set(include ${FLANG_BINARY_DIR}/include/flang)
# 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()
#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"
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) {
}
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);
projects / platform / upstream / llvm.git / commitdiff