[flang-commits] [flang] 79caf69 - [flang] Runtime implementation for default derived type formatted I/O
peter klausler via flang-commits
flang-commits at lists.llvm.org
Fri Jun 18 10:30:39 PDT 2021
Author: peter klausler
Date: 2021-06-18T10:30:28-07:00
New Revision: 79caf69cc08a72022f968020eab486b698fd4178
URL: https://github.com/llvm/llvm-project/commit/79caf69cc08a72022f968020eab486b698fd4178
DIFF: https://github.com/llvm/llvm-project/commit/79caf69cc08a72022f968020eab486b698fd4178.diff
LOG: [flang] Runtime implementation for default derived type formatted I/O
This is *not* user-defined derived type I/O, but rather Fortran's
built-in capabilities for using derived type data in I/O lists
and NAMELIST groups.
This feature depends on having the derived type description tables
that are created by Semantics available, passed through compilation
as initialized static objects to which pointers can be targeted
in the descriptors of I/O list items and NAMELIST groups.
NAMELIST processing now handles component references on input
(e.g., "&GROUP x%component = 123 /").
The C++ perspectives of the derived type information records
were transformed into proper classes when it was necessary to add
member functions to them.
The code in Semantics that generates derived type information
was changed to emit derived type components in component order,
not alphabetic order.
Differential Revision: https://reviews.llvm.org/D104485
Added:
flang/runtime/type-info.cpp
Modified:
flang/include/flang/Semantics/runtime-type-info.h
flang/lib/Semantics/runtime-type-info.cpp
flang/runtime/CMakeLists.txt
flang/runtime/copy.cpp
flang/runtime/derived.cpp
flang/runtime/descriptor-io.h
flang/runtime/descriptor.cpp
flang/runtime/descriptor.h
flang/runtime/namelist.cpp
flang/runtime/tools.h
flang/runtime/type-info.h
flang/test/Semantics/typeinfo01.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/runtime-type-info.h b/flang/include/flang/Semantics/runtime-type-info.h
index 71b5cac58eb5..7521a93ea71f 100644
--- a/flang/include/flang/Semantics/runtime-type-info.h
+++ b/flang/include/flang/Semantics/runtime-type-info.h
@@ -33,6 +33,5 @@ struct RuntimeDerivedTypeTables {
RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(SemanticsContext &);
-void Dump(llvm::raw_ostream &, const RuntimeDerivedTypeTables &);
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_RUNTIME_TYPE_INFO_H_
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index a5a0199b61d8..f336117ab3a5 100644
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -427,7 +427,7 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds)));
// Traverse the components of the derived type
if (!isPDTdefinition) {
- std::vector<evaluate::StructureConstructor> dataComponents;
+ std::vector<const Symbol *> dataComponentSymbols;
std::vector<evaluate::StructureConstructor> procPtrComponents;
std::vector<evaluate::StructureConstructor> specials;
for (const auto &pair : dtScope) {
@@ -438,9 +438,8 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
[&](const TypeParamDetails &) {
// already handled above in declaration order
},
- [&](const ObjectEntityDetails &object) {
- dataComponents.emplace_back(DescribeComponent(
- symbol, object, scope, dtScope, distinctName, parameters));
+ [&](const ObjectEntityDetails &) {
+ dataComponentSymbols.push_back(&symbol);
},
[&](const ProcEntityDetails &proc) {
if (IsProcedurePointer(symbol)) {
@@ -461,6 +460,18 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
},
symbol.details());
}
+ // Sort the data component symbols by offset before emitting them
+ std::sort(dataComponentSymbols.begin(), dataComponentSymbols.end(),
+ [](const Symbol *x, const Symbol *y) {
+ return x->offset() < y->offset();
+ });
+ std::vector<evaluate::StructureConstructor> dataComponents;
+ for (const Symbol *symbol : dataComponentSymbols) {
+ auto locationRestorer{common::ScopedSet(location_, symbol->name())};
+ dataComponents.emplace_back(
+ DescribeComponent(*symbol, symbol->get<ObjectEntityDetails>(), scope,
+ dtScope, distinctName, parameters));
+ }
AddValue(dtValues, derivedTypeSchema_, "component"s,
SaveDerivedPointerTarget(scope, SaveObjectName(".c."s + distinctName),
std::move(dataComponents),
diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt
index e5e6657fc887..5f4bbc73c23d 100644
--- a/flang/runtime/CMakeLists.txt
+++ b/flang/runtime/CMakeLists.txt
@@ -70,6 +70,7 @@ add_flang_library(FortranRuntime
tools.cpp
transformational.cpp
type-code.cpp
+ type-info.cpp
unit.cpp
unit-map.cpp
diff --git a/flang/runtime/copy.cpp b/flang/runtime/copy.cpp
index 458b8f0a16da..1315472ef50f 100644
--- a/flang/runtime/copy.cpp
+++ b/flang/runtime/copy.cpp
@@ -26,20 +26,20 @@ void CopyElement(const Descriptor &to, const SubscriptValue toAt[],
if (const auto *derived{addendum->derivedType()}) {
RUNTIME_CHECK(terminator,
from.Addendum() && derived == from.Addendum()->derivedType());
- const Descriptor &componentDesc{derived->component.descriptor()};
+ const Descriptor &componentDesc{derived->component()};
const typeInfo::Component *component{
componentDesc.OffsetElement<typeInfo::Component>()};
std::size_t nComponents{componentDesc.Elements()};
for (std::size_t j{0}; j < nComponents; ++j, ++component) {
- if (component->genre == typeInfo::Component::Genre::Allocatable ||
- component->genre == typeInfo::Component::Genre::Automatic) {
+ if (component->genre() == typeInfo::Component::Genre::Allocatable ||
+ component->genre() == typeInfo::Component::Genre::Automatic) {
Descriptor &toDesc{
- *reinterpret_cast<Descriptor *>(toPtr + component->offset)};
+ *reinterpret_cast<Descriptor *>(toPtr + component->offset())};
if (toDesc.raw().base_addr != nullptr) {
toDesc.set_base_addr(nullptr);
RUNTIME_CHECK(terminator, toDesc.Allocate() == CFI_SUCCESS);
const Descriptor &fromDesc{*reinterpret_cast<const Descriptor *>(
- fromPtr + component->offset)};
+ fromPtr + component->offset())};
CopyArray(toDesc, fromDesc, terminator);
}
}
diff --git a/flang/runtime/derived.cpp b/flang/runtime/derived.cpp
index db743ba3a1be..ef4bddc8a466 100644
--- a/flang/runtime/derived.cpp
+++ b/flang/runtime/derived.cpp
@@ -15,7 +15,7 @@ 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()};
+ const Descriptor &specialDesc{derived.special()};
std::size_t totalSpecialBindings{specialDesc.Elements()};
for (std::size_t j{0}; j < totalSpecialBindings; ++j) {
const auto &special{
@@ -59,15 +59,6 @@ static void CallFinalSubroutine(
}
}
-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.
@@ -76,46 +67,39 @@ void Destroy(const Descriptor &descriptor, bool finalize,
if (finalize) {
CallFinalSubroutine(descriptor, derived);
}
- const Descriptor &componentDesc{derived.component.descriptor()};
- std::int64_t myComponents{componentDesc.GetDimension(0).Extent()};
+ const Descriptor &componentDesc{derived.component()};
+ auto myComponents{static_cast<SubscriptValue>(componentDesc.Elements())};
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) {
+ 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)
+ descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset())
->Deallocate(finalize);
}
- } else if (comp.genre == typeInfo::Component::Genre::Data &&
- comp.derivedType.descriptor().raw().base_addr) {
+ } else if (comp.genre() == typeInfo::Component::Genre::Data &&
+ comp.derivedType()) {
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;
+ const typeInfo::Value *bounds{comp.bounds()};
+ for (int dim{0}; dim < comp.rank(); ++dim) {
+ extent[dim] = bounds[2 * dim].GetValue(&descriptor).value_or(0) -
+ bounds[2 * dim + 1].GetValue(&descriptor).value_or(0) + 1;
}
StaticDescriptor<maxRank, true, 0> staticDescriptor;
Descriptor &compDesc{staticDescriptor.descriptor()};
- const auto &compType{*comp.derivedType.descriptor()
- .OffsetElement<typeInfo::DerivedType>()};
+ const typeInfo::DerivedType &compType{*comp.derivedType()};
for (std::size_t j{0}; j < elements; ++j) {
compDesc.Establish(compType,
- descriptor.OffsetElement<char>(j * byteStride + comp.offset),
- comp.rank, extent);
+ descriptor.OffsetElement<char>(j * byteStride + comp.offset()),
+ comp.rank(), extent);
Destroy(compDesc, finalize, compType);
}
}
}
- const Descriptor &parentDesc{derived.parent.descriptor()};
+ const Descriptor &parentDesc{derived.parent()};
if (const auto *parent{parentDesc.OffsetElement<typeInfo::DerivedType>()}) {
Destroy(descriptor, finalize, *parent);
}
diff --git a/flang/runtime/descriptor-io.h b/flang/runtime/descriptor-io.h
index e664f4c9874d..09d068612325 100644
--- a/flang/runtime/descriptor-io.h
+++ b/flang/runtime/descriptor-io.h
@@ -17,6 +17,7 @@
#include "edit-output.h"
#include "io-stmt.h"
#include "terminator.h"
+#include "type-info.h"
#include "flang/Common/uint128.h"
namespace Fortran::runtime::io::descr {
@@ -25,7 +26,8 @@ inline A &ExtractElement(IoStatementState &io, const Descriptor &descriptor,
const SubscriptValue subscripts[]) {
A *p{descriptor.Element<A>(subscripts)};
if (!p) {
- io.GetIoErrorHandler().Crash("ExtractElement: subscripts out of range");
+ io.GetIoErrorHandler().Crash(
+ "ExtractElement: null base address or subscripts out of range");
}
return *p;
}
@@ -216,6 +218,67 @@ inline bool FormattedLogicalIO(
return true;
}
+template <Direction DIR>
+static bool DescriptorIO(IoStatementState &, const Descriptor &);
+
+template <Direction DIR>
+static bool DefaultFormattedComponentIO(IoStatementState &io,
+ const typeInfo::Component &component, const Descriptor &origDescriptor,
+ const SubscriptValue origSubscripts[], Terminator &terminator) {
+ if (component.genre() == typeInfo::Component::Genre::Data) {
+ // Create a descriptor for the component
+ StaticDescriptor<maxRank, true, 16 /*?*/> statDesc;
+ Descriptor &desc{statDesc.descriptor()};
+ component.EstablishDescriptor(
+ desc, origDescriptor, origSubscripts, terminator);
+ return DescriptorIO<DIR>(io, desc);
+ } else {
+ // Component is itself a descriptor
+ char *pointer{
+ origDescriptor.Element<char>(origSubscripts) + component.offset()};
+ RUNTIME_CHECK(
+ terminator, component.genre() == typeInfo::Component::Genre::Automatic);
+ const Descriptor &compDesc{*reinterpret_cast<const Descriptor *>(pointer)};
+ return DescriptorIO<DIR>(io, compDesc);
+ }
+}
+
+template <Direction DIR>
+static bool FormattedDerivedTypeIO(
+ IoStatementState &io, const Descriptor &descriptor) {
+ Terminator &terminator{io.GetIoErrorHandler()};
+ const DescriptorAddendum *addendum{descriptor.Addendum()};
+ RUNTIME_CHECK(terminator, addendum != nullptr);
+ const typeInfo::DerivedType *type{addendum->derivedType()};
+ RUNTIME_CHECK(terminator, type != nullptr);
+ if (false) {
+ // TODO: user-defined derived type formatted I/O
+ } else {
+ // Default derived type formatting
+ const Descriptor &compArray{type->component()};
+ RUNTIME_CHECK(terminator, compArray.rank() == 1);
+ std::size_t numComponents{compArray.Elements()};
+ std::size_t numElements{descriptor.Elements()};
+ SubscriptValue subscripts[maxRank];
+ descriptor.GetLowerBounds(subscripts);
+ for (std::size_t j{0}; j < numElements;
+ ++j, descriptor.IncrementSubscripts(subscripts)) {
+ SubscriptValue at[maxRank];
+ compArray.GetLowerBounds(at);
+ for (std::size_t k{0}; k < numComponents;
+ ++k, compArray.IncrementSubscripts(at)) {
+ const typeInfo::Component &component{
+ *compArray.Element<typeInfo::Component>(at)};
+ if (!DefaultFormattedComponentIO<DIR>(
+ io, component, descriptor, subscripts, terminator)) {
+ return false;
+ }
+ }
+ }
+ }
+ return true;
+}
+
template <Direction DIR>
static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
if (!io.get_if<IoDirectionState<DIR>>()) {
@@ -233,7 +296,9 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
SubscriptValue subscripts[maxRank];
descriptor.GetLowerBounds(subscripts);
std::size_t numElements{descriptor.Elements()};
- if (descriptor.IsContiguous()) { // contiguous unformatted I/O
+ if (false) {
+ // TODO: user-defined derived type unformatted I/O
+ } else if (descriptor.IsContiguous()) { // contiguous unformatted I/O
char &x{ExtractElement<char>(io, descriptor, subscripts)};
auto totalBytes{numElements * elementBytes};
if constexpr (DIR == Direction::Output) {
@@ -360,10 +425,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
return false;
}
case TypeCategory::Derived:
- io.GetIoErrorHandler().Crash(
- "DescriptorIO: Unimplemented: derived type I/O",
- static_cast<int>(descriptor.type().raw()));
- return false;
+ return FormattedDerivedTypeIO<DIR>(io, descriptor);
}
}
io.GetIoErrorHandler().Crash("DescriptorIO: Bad type code (%d) in descriptor",
diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp
index 6747b38908ad..ba97b876eceb 100644
--- a/flang/runtime/descriptor.cpp
+++ b/flang/runtime/descriptor.cpp
@@ -42,9 +42,12 @@ void Descriptor::Establish(TypeCode t, std::size_t elementBytes, void *p,
// incoming element length is replaced by 4 so that it will be valid
// for all CHARACTER kinds.
std::size_t workaroundElemLen{elementBytes ? elementBytes : 4};
- RUNTIME_CHECK(terminator,
- ISO::CFI_establish(&raw_, p, attribute, t.raw(), workaroundElemLen, rank,
- extent) == CFI_SUCCESS);
+ int cfiStatus{ISO::CFI_establish(
+ &raw_, p, attribute, t.raw(), workaroundElemLen, rank, extent)};
+ if (cfiStatus != CFI_SUCCESS) {
+ terminator.Crash(
+ "Descriptor::Establish: CFI_establish returned %d", cfiStatus, t.raw());
+ }
if (elementBytes == 0) {
raw_.elem_len = 0;
for (int j{0}; j < rank; ++j) {
@@ -75,7 +78,8 @@ void Descriptor::Establish(int characterKind, std::size_t characters, void *p,
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(TypeCode{TypeCategory::Derived, 0}, dt.sizeInBytes(), p, rank,
+ extent, attribute, true);
DescriptorAddendum *a{Addendum()};
Terminator terminator{__FILE__, __LINE__};
RUNTIME_CHECK(terminator, a != nullptr);
@@ -109,8 +113,8 @@ OwningPtr<Descriptor> Descriptor::Create(int characterKind,
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());
+ return Create(TypeCode{TypeCategory::Derived, 0}, dt.sizeInBytes(), p, rank,
+ extent, attribute, dt.LenParameters());
}
std::size_t Descriptor::SizeInBytes() const {
diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h
index d31023b338af..e5cf0d22b3c3 100644
--- a/flang/runtime/descriptor.h
+++ b/flang/runtime/descriptor.h
@@ -109,8 +109,9 @@ class DescriptorAddendum {
return len_[which];
}
static constexpr std::size_t SizeInBytes(int lenParameters) {
- return sizeof(DescriptorAddendum) - sizeof(typeInfo::TypeParameterValue) +
- lenParameters * sizeof(typeInfo::TypeParameterValue);
+ // TODO: Don't waste that last word if lenParameters == 0
+ return sizeof(DescriptorAddendum) +
+ std::max(lenParameters - 1, 0) * sizeof(typeInfo::TypeParameterValue);
}
std::size_t SizeInBytes() const;
diff --git a/flang/runtime/namelist.cpp b/flang/runtime/namelist.cpp
index f26ae849dbd2..0b334b40dea2 100644
--- a/flang/runtime/namelist.cpp
+++ b/flang/runtime/namelist.cpp
@@ -15,6 +15,10 @@
namespace Fortran::runtime::io {
+// Max size of a group, symbol or component identifier that can appear in
+// NAMELIST input, plus a byte for NUL termination.
+static constexpr std::size_t nameBufferSize{201};
+
bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
IoStatementState &io{*cookie};
io.CheckFormattedStmtType<Direction::Output>("OutputNamelist");
@@ -56,22 +60,29 @@ bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
return EmitWithAdvance('/');
}
+static constexpr bool IsLegalIdStart(char32_t ch) {
+ return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || ch == '_' ||
+ ch == '@' || ch == '$';
+}
+
+static constexpr bool IsLegalIdChar(char32_t ch) {
+ return IsLegalIdStart(ch) || (ch >= '0' && ch <= '9');
+}
+
+static constexpr char NormalizeIdChar(char32_t ch) {
+ return static_cast<char>(ch >= 'A' && ch <= 'Z' ? ch - 'A' + 'a' : ch);
+}
+
static bool GetLowerCaseName(
IoStatementState &io, char buffer[], std::size_t maxLength) {
- if (auto ch{io.GetCurrentChar()}) {
- static const auto IsLegalIdStart{[](char32_t ch) -> bool {
- return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') ||
- ch == '_' || ch == '@' || ch == '$';
- }};
+ if (auto ch{io.GetNextNonBlank()}) {
if (IsLegalIdStart(*ch)) {
std::size_t j{0};
do {
- buffer[j] =
- static_cast<char>(*ch >= 'A' && *ch <= 'Z' ? *ch - 'A' + 'a' : *ch);
+ buffer[j] = NormalizeIdChar(*ch);
io.HandleRelativePosition(1);
ch = io.GetCurrentChar();
- } while (++j < maxLength && ch &&
- (IsLegalIdStart(*ch) || (*ch >= '0' && *ch <= '9')));
+ } while (++j < maxLength && ch && IsLegalIdChar(*ch));
buffer[j++] = '\0';
if (j <= maxLength) {
return true;
@@ -118,8 +129,8 @@ static bool HandleSubscripts(IoStatementState &io, Descriptor &desc,
const Descriptor &source, const char *name) {
IoErrorHandler &handler{io.GetIoErrorHandler()};
io.HandleRelativePosition(1); // skip '('
- // Allow for blanks in subscripts; it's nonstandard, but not ambiguous
- // within the parentheses
+ // Allow for blanks in subscripts; they're nonstandard, but not
+ // ambiguous within the parentheses.
SubscriptValue lower[maxRank], upper[maxRank], stride[maxRank];
int j{0};
std::size_t elemLen{source.ElementBytes()};
@@ -211,6 +222,38 @@ static bool HandleSubscripts(IoStatementState &io, Descriptor &desc,
return false;
}
+static bool HandleComponent(IoStatementState &io, Descriptor &desc,
+ const Descriptor &source, const char *name) {
+ IoErrorHandler &handler{io.GetIoErrorHandler()};
+ io.HandleRelativePosition(1); // skip '%'
+ char compName[nameBufferSize];
+ if (GetLowerCaseName(io, compName, sizeof compName)) {
+ const DescriptorAddendum *addendum{source.Addendum()};
+ if (const typeInfo::DerivedType *
+ type{addendum ? addendum->derivedType() : nullptr}) {
+ if (const typeInfo::Component *
+ comp{type->FindDataComponent(compName, std::strlen(compName))}) {
+ comp->EstablishDescriptor(desc, source, nullptr, handler);
+ return true;
+ } else {
+ handler.SignalError(
+ "NAMELIST component reference '%%%s' of input group item %s is not "
+ "a component of its derived type",
+ compName, name);
+ }
+ } else {
+ handler.SignalError("NAMELIST component reference '%%%s' of input group "
+ "item %s for non-derived type",
+ compName, name);
+ }
+ } else {
+ handler.SignalError("NAMELIST component reference of input group item %s "
+ "has no name after '%'",
+ name);
+ }
+ return false;
+}
+
bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
IoStatementState &io{*cookie};
io.CheckFormattedStmtType<Direction::Input>("InputNamelist");
@@ -225,7 +268,7 @@ bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
return false;
}
io.HandleRelativePosition(1);
- char name[101];
+ char name[nameBufferSize];
if (!GetLowerCaseName(io, name, sizeof name)) {
handler.SignalError("NAMELIST input group has no name");
return false;
@@ -268,15 +311,14 @@ bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
next = io.GetCurrentChar();
if (next && (*next == '(' || *next == '%')) {
do {
+ Descriptor &mutableDescriptor{staticDesc[whichStaticDesc].descriptor()};
+ whichStaticDesc ^= 1;
if (*next == '(') {
- Descriptor &mutableDescriptor{
- staticDesc[whichStaticDesc].descriptor()};
- whichStaticDesc ^= 1;
HandleSubscripts(io, mutableDescriptor, *useDescriptor, name);
- useDescriptor = &mutableDescriptor;
} else {
- handler.Crash("unimplemented: component references in NAMELIST");
+ HandleComponent(io, mutableDescriptor, *useDescriptor, name);
}
+ useDescriptor = &mutableDescriptor;
next = io.GetCurrentChar();
} while (next && (*next == '(' || *next == '%'));
}
diff --git a/flang/runtime/tools.h b/flang/runtime/tools.h
index d4a070868abc..2daa53aecf21 100644
--- a/flang/runtime/tools.h
+++ b/flang/runtime/tools.h
@@ -333,5 +333,6 @@ std::optional<std::pair<TypeCategory, int>> inline constexpr GetResultType(
}
return std::nullopt;
}
+
} // namespace Fortran::runtime
#endif // FORTRAN_RUNTIME_TOOLS_H_
diff --git a/flang/runtime/type-info.cpp b/flang/runtime/type-info.cpp
new file mode 100644
index 000000000000..ef3c4724fa00
--- /dev/null
+++ b/flang/runtime/type-info.cpp
@@ -0,0 +1,183 @@
+//===-- runtime/type-info.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 "type-info.h"
+#include "terminator.h"
+#include <cstdio>
+
+namespace Fortran::runtime::typeInfo {
+
+std::optional<TypeParameterValue> Value::GetValue(
+ const Descriptor *descriptor) const {
+ switch (genre_) {
+ case Genre::Explicit:
+ return value_;
+ case Genre::LenParameter:
+ if (descriptor) {
+ if (const auto *addendum{descriptor->Addendum()}) {
+ return addendum->LenParameterValue(value_);
+ }
+ }
+ return std::nullopt;
+ default:
+ return std::nullopt;
+ }
+}
+
+void Component::EstablishDescriptor(Descriptor &descriptor,
+ const Descriptor &container, const SubscriptValue subscripts[],
+ Terminator &terminator) const {
+ RUNTIME_CHECK(terminator, genre_ == Genre::Data);
+ TypeCategory cat{category()};
+ if (cat == TypeCategory::Character) {
+ auto length{characterLen_.GetValue(&container)};
+ RUNTIME_CHECK(terminator, length.has_value());
+ descriptor.Establish(kind_, *length / kind_, nullptr, rank_);
+ } else if (cat == TypeCategory::Derived) {
+ const DerivedType *type{derivedType()};
+ RUNTIME_CHECK(terminator, type != nullptr);
+ descriptor.Establish(*type, nullptr, rank_);
+ } else {
+ descriptor.Establish(cat, kind_, nullptr, rank_);
+ }
+ if (rank_) {
+ const typeInfo::Value *boundValues{bounds()};
+ RUNTIME_CHECK(terminator, boundValues != nullptr);
+ auto byteStride{static_cast<SubscriptValue>(descriptor.ElementBytes())};
+ for (int j{0}; j < rank_; ++j) {
+ auto lb{boundValues++->GetValue(&container)};
+ auto ub{boundValues++->GetValue(&container)};
+ RUNTIME_CHECK(terminator, lb.has_value() && ub.has_value());
+ Dimension &dim{descriptor.GetDimension(j)};
+ dim.SetBounds(*lb, *ub);
+ dim.SetByteStride(byteStride);
+ byteStride *= dim.Extent();
+ }
+ }
+ descriptor.set_base_addr(container.Element<char>(subscripts) + offset_);
+}
+
+const Component *DerivedType::FindDataComponent(
+ const char *compName, std::size_t compNameLen) const {
+ const Descriptor &compDesc{component()};
+ std::size_t n{compDesc.Elements()};
+ SubscriptValue at[maxRank];
+ compDesc.GetLowerBounds(at);
+ for (std::size_t j{0}; j < n; ++j, compDesc.IncrementSubscripts(at)) {
+ const Component *component{compDesc.Element<Component>(at)};
+ INTERNAL_CHECK(component != nullptr);
+ const Descriptor &nameDesc{component->name()};
+ if (nameDesc.ElementBytes() == compNameLen &&
+ std::memcmp(compName, nameDesc.OffsetElement(), compNameLen) == 0) {
+ return component;
+ }
+ }
+ const DerivedType *ancestor{parent().OffsetElement<DerivedType>()};
+ return ancestor ? ancestor->FindDataComponent(compName, compNameLen)
+ : nullptr;
+}
+
+static void DumpScalarCharacter(
+ FILE *f, const Descriptor &desc, const char *what) {
+ if (desc.raw().version == CFI_VERSION &&
+ desc.type() == TypeCode{TypeCategory::Character, 1} &&
+ desc.ElementBytes() > 0 && desc.rank() == 0 &&
+ desc.OffsetElement() != nullptr) {
+ std::fwrite(desc.OffsetElement(), desc.ElementBytes(), 1, f);
+ } else {
+ std::fprintf(f, "bad %s descriptor: ", what);
+ desc.Dump(f);
+ }
+}
+
+FILE *DerivedType::Dump(FILE *f) const {
+ std::fprintf(
+ f, "DerivedType @ 0x%p:\n", reinterpret_cast<const void *>(this));
+ const std::uint64_t *uints{reinterpret_cast<const std::uint64_t *>(this)};
+ for (int j{0}; j < 64; ++j) {
+ int offset{j * static_cast<int>(sizeof *uints)};
+ std::fprintf(f, " [+%3d](0x%p) %#016jx", offset,
+ reinterpret_cast<const void *>(&uints[j]),
+ static_cast<std::intmax_t>(uints[j]));
+ if (offset == offsetof(DerivedType, binding_)) {
+ std::fputs(" <-- binding_\n", f);
+ } else if (offset == offsetof(DerivedType, name_)) {
+ std::fputs(" <-- name_\n", f);
+ } else if (offset == offsetof(DerivedType, sizeInBytes_)) {
+ std::fputs(" <-- sizeInBytes_\n", f);
+ } else if (offset == offsetof(DerivedType, parent_)) {
+ std::fputs(" <-- parent_\n", f);
+ } else if (offset == offsetof(DerivedType, uninstantiated_)) {
+ std::fputs(" <-- uninstantiated_\n", f);
+ } else if (offset == offsetof(DerivedType, typeHash_)) {
+ std::fputs(" <-- typeHash_\n", f);
+ } else if (offset == offsetof(DerivedType, kindParameter_)) {
+ std::fputs(" <-- kindParameter_\n", f);
+ } else if (offset == offsetof(DerivedType, lenParameterKind_)) {
+ std::fputs(" <-- lenParameterKind_\n", f);
+ } else if (offset == offsetof(DerivedType, component_)) {
+ std::fputs(" <-- component_\n", f);
+ } else if (offset == offsetof(DerivedType, procPtr_)) {
+ std::fputs(" <-- procPtr_\n", f);
+ } else if (offset == offsetof(DerivedType, special_)) {
+ std::fputs(" <-- special_\n", f);
+ } else {
+ std::fputc('\n', f);
+ }
+ }
+ std::fputs(" name: ", f);
+ DumpScalarCharacter(f, name(), "DerivedType::name");
+ const Descriptor &bindingDesc{binding()};
+ std::fprintf(
+ f, "\n binding descriptor (byteSize 0x%zx): ", binding_.byteSize);
+ bindingDesc.Dump(f);
+ const Descriptor &compDesc{component()};
+ std::fputs("\n components:\n", f);
+ if (compDesc.raw().version == CFI_VERSION &&
+ compDesc.type() == TypeCode{TypeCategory::Derived, 0} &&
+ compDesc.ElementBytes() == sizeof(Component) && compDesc.rank() == 1) {
+ std::size_t n{compDesc.Elements()};
+ for (std::size_t j{0}; j < n; ++j) {
+ const Component &comp{*compDesc.ZeroBasedIndexedElement<Component>(j)};
+ std::fprintf(f, " [%3zd] ", j);
+ comp.Dump(f);
+ }
+ } else {
+ std::fputs(" bad descriptor: ", f);
+ compDesc.Dump(f);
+ }
+ return f;
+}
+
+FILE *Component::Dump(FILE *f) const {
+ std::fprintf(f, "Component @ 0x%p:\n", reinterpret_cast<const void *>(this));
+ std::fputs(" name: ", f);
+ DumpScalarCharacter(f, name(), "Component::name");
+ switch (genre_) {
+ case Genre::Data:
+ std::fputs(" Data ", f);
+ break;
+ case Genre::Pointer:
+ std::fputs(" Pointer ", f);
+ break;
+ case Genre::Allocatable:
+ std::fputs(" Allocatable", f);
+ break;
+ case Genre::Automatic:
+ std::fputs(" Automatic ", f);
+ break;
+ default:
+ std::fprintf(f, " (bad genre 0x%x)", static_cast<int>(genre_));
+ break;
+ }
+ std::fprintf(f, " category %d kind %d rank %d offset 0x%zx\n", category_,
+ kind_, rank_, static_cast<std::size_t>(offset_));
+ return f;
+}
+
+} // namespace Fortran::runtime::typeInfo
diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h
index c83a5f2f517e..21c955dd0ec8 100644
--- a/flang/runtime/type-info.h
+++ b/flang/runtime/type-info.h
@@ -16,24 +16,54 @@
#include "flang/Common/Fortran.h"
#include <cinttypes>
#include <memory>
+#include <optional>
namespace Fortran::runtime::typeInfo {
+struct Component;
+
class DerivedType {
public:
- ~DerivedType();
+ ~DerivedType(); // never defined
+
+ const Descriptor &binding() const { return binding_.descriptor(); }
+ const Descriptor &name() const { return name_.descriptor(); }
+ std::uint64_t sizeInBytes() const { return sizeInBytes_; }
+ const Descriptor &parent() const { return parent_.descriptor(); }
+ std::uint64_t typeHash() const { return typeHash_; }
+ const Descriptor &uninstatiated() const {
+ return uninstantiated_.descriptor();
+ }
+ const Descriptor &kindParameter() const {
+ return kindParameter_.descriptor();
+ }
+ const Descriptor &lenParameterKind() const {
+ return lenParameterKind_.descriptor();
+ }
+ const Descriptor &component() const { return component_.descriptor(); }
+ const Descriptor &procPtr() const { return procPtr_.descriptor(); }
+ const Descriptor &special() const { return special_.descriptor(); }
+
+ std::size_t LenParameters() const { return lenParameterKind().Elements(); }
+
+ // Finds a data component by name in this derived type or tis ancestors.
+ const Component *FindDataComponent(
+ const char *name, std::size_t nameLen) const;
+ FILE *Dump(FILE * = stdout) const;
+
+private:
// 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, true>
- binding; // TYPE(BINDING), DIMENSION(:), POINTER, CONTIGUOUS
+ binding_; // TYPE(BINDING), DIMENSION(:), POINTER, CONTIGUOUS
- StaticDescriptor<0> name; // CHARACTER(:), POINTER
+ StaticDescriptor<0> name_; // CHARACTER(:), POINTER
- std::uint64_t sizeInBytes{0};
- StaticDescriptor<0, true> parent; // TYPE(DERIVEDTYPE), POINTER
+ std::uint64_t sizeInBytes_{0};
+ StaticDescriptor<0, true> parent_; // TYPE(DERIVEDTYPE), POINTER
// Instantiations of a parameterized derived type with KIND type
// parameters will point this data member to the description of
@@ -41,32 +71,30 @@ class DerivedType {
// 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, true> uninstantiated; // TYPE(DERIVEDTYPE), POINTER
+ StaticDescriptor<0, true> uninstantiated_; // TYPE(DERIVEDTYPE), POINTER
// TODO: flags for SEQUENCE, BIND(C), any PRIVATE component(? see 7.5.2)
- std::uint64_t typeHash{0};
+ 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)
+ 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.
+ // TODO pmk: fix to be "component order"
// It does not include procedure pointer components.
StaticDescriptor<1, true>
- component; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS
+ component_; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS
// Procedure pointer components
StaticDescriptor<1, true>
- procPtr; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS
+ procPtr_; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS
// Does not include special bindings from ancestral types.
StaticDescriptor<1, true>
- special; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS
-
- std::size_t LenParameters() const {
- return lenParameterKind.descriptor().Elements();
- }
+ special_; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS
};
using ProcedurePointer = void (*)(); // TYPE(C_FUNPTR)
@@ -76,33 +104,70 @@ struct Binding {
StaticDescriptor<0> name; // CHARACTER(:), POINTER
};
-struct Value {
+class Value {
+public:
enum class Genre : std::uint8_t {
Deferred = 1,
Explicit = 2,
LenParameter = 3
};
- Genre genre{Genre::Explicit};
+
+ std::optional<TypeParameterValue> GetValue(const Descriptor *) const;
+
+private:
+ 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};
+ 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
+class Component {
+public:
+ enum class Genre : std::uint8_t {
+ Data = 1,
+ Pointer = 2,
+ Allocatable = 3,
+ Automatic = 4
+ };
+
+ const Descriptor &name() const { return name_.descriptor(); }
+ Genre genre() const { return genre_; }
+ TypeCategory category() const { return static_cast<TypeCategory>(category_); }
+ int kind() const { return kind_; }
+ int rank() const { return rank_; }
+ std::uint64_t offset() const { return offset_; }
+ const Value &characterLen() const { return characterLen_; }
+ const DerivedType *derivedType() const {
+ return derivedType_.descriptor().OffsetElement<const DerivedType>();
+ }
+ const Value *lenValue() const {
+ return lenValue_.descriptor().OffsetElement<const Value>();
+ }
+ const Value *bounds() const {
+ return bounds_.descriptor().OffsetElement<const Value>();
+ }
+ const char *initialization() const { return initialization_; }
+
+ // Creates a pointer descriptor from a component description.
+ void EstablishDescriptor(Descriptor &, const Descriptor &container,
+ const SubscriptValue[], Terminator &) const;
+
+ FILE *Dump(FILE * = stdout) const;
+
+private:
+ 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(:), CONTIGUOUS
+ lenValue_; // TYPE(VALUE), POINTER, DIMENSION(:), CONTIGUOUS
StaticDescriptor<2, true>
- bounds; // TYPE(VALUE), POINTER, DIMENSION(2,:), CONTIGUOUS
- char *initialization{nullptr}; // for Genre::Data and Pointer
+ bounds_; // TYPE(VALUE), POINTER, DIMENSION(2,:), CONTIGUOUS
+ const char *initialization_{nullptr}; // for Genre::Data and Pointer
// TODO: cobounds
// TODO: `PRIVATE` attribute
};
diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90
index b429882b93cb..a68c392ad751 100644
--- a/flang/test/Semantics/typeinfo01.f90
+++ b/flang/test/Semantics/typeinfo01.f90
@@ -20,7 +20,7 @@ module m02
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.child, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:1_8 init:[component::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()),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())]
!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())
@@ -232,7 +232,7 @@ module m11
contains
subroutine s1(x)
!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=NULL(),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: .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=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),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.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())]
!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
More information about the flang-commits
mailing list