fc97d2e68b
Implement the UNSIGNED extension type and operations under control of a language feature flag (-funsigned). This is nearly identical to the UNSIGNED feature that has been available in Sun Fortran for years, and now implemented in GNU Fortran for gfortran 15, and proposed for ISO standardization in J3/24-116.txt. See the new documentation for details; but in short, this is C's unsigned type, with guaranteed modular arithmetic for +, -, and *, and the related transformational intrinsic functions SUM & al.
335 lines
12 KiB
C++
335 lines
12 KiB
C++
//===-- 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 "tools.h"
|
|
#include <cstdio>
|
|
|
|
namespace Fortran::runtime::typeInfo {
|
|
|
|
RT_OFFLOAD_API_GROUP_BEGIN
|
|
|
|
RT_API_ATTRS Fortran::common::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 Fortran::common::nullopt;
|
|
default:
|
|
return Fortran::common::nullopt;
|
|
}
|
|
}
|
|
|
|
RT_API_ATTRS std::size_t Component::GetElementByteSize(
|
|
const Descriptor &instance) const {
|
|
switch (category()) {
|
|
case TypeCategory::Integer:
|
|
case TypeCategory::Unsigned:
|
|
case TypeCategory::Real:
|
|
case TypeCategory::Logical:
|
|
return kind_;
|
|
case TypeCategory::Complex:
|
|
return 2 * kind_;
|
|
case TypeCategory::Character:
|
|
if (auto value{characterLen_.GetValue(&instance)}) {
|
|
return kind_ * *value;
|
|
}
|
|
break;
|
|
case TypeCategory::Derived:
|
|
if (const auto *type{derivedType()}) {
|
|
return type->sizeInBytes();
|
|
}
|
|
break;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
RT_API_ATTRS std::size_t Component::GetElements(
|
|
const Descriptor &instance) const {
|
|
std::size_t elements{1};
|
|
if (int rank{rank_}) {
|
|
if (const Value * boundValues{bounds()}) {
|
|
for (int j{0}; j < rank; ++j) {
|
|
TypeParameterValue lb{
|
|
boundValues[2 * j].GetValue(&instance).value_or(0)};
|
|
TypeParameterValue ub{
|
|
boundValues[2 * j + 1].GetValue(&instance).value_or(0)};
|
|
if (ub >= lb) {
|
|
elements *= ub - lb + 1;
|
|
} else {
|
|
return 0;
|
|
}
|
|
}
|
|
} else {
|
|
return 0;
|
|
}
|
|
}
|
|
return elements;
|
|
}
|
|
|
|
RT_API_ATTRS std::size_t Component::SizeInBytes(
|
|
const Descriptor &instance) const {
|
|
if (genre() == Genre::Data) {
|
|
return GetElementByteSize(instance) * GetElements(instance);
|
|
} else if (category() == TypeCategory::Derived) {
|
|
const DerivedType *type{derivedType()};
|
|
return Descriptor::SizeInBytes(
|
|
rank_, true, type ? type->LenParameters() : 0);
|
|
} else {
|
|
return Descriptor::SizeInBytes(rank_);
|
|
}
|
|
}
|
|
|
|
RT_API_ATTRS void Component::EstablishDescriptor(Descriptor &descriptor,
|
|
const Descriptor &container, Terminator &terminator) const {
|
|
ISO::CFI_attribute_t attribute{static_cast<ISO::CFI_attribute_t>(
|
|
genre_ == Genre::Allocatable ? CFI_attribute_allocatable
|
|
: genre_ == Genre::Pointer ? CFI_attribute_pointer
|
|
: CFI_attribute_other)};
|
|
TypeCategory cat{category()};
|
|
if (cat == TypeCategory::Character) {
|
|
std::size_t lengthInChars{0};
|
|
if (auto length{characterLen_.GetValue(&container)}) {
|
|
lengthInChars = static_cast<std::size_t>(*length);
|
|
} else {
|
|
RUNTIME_CHECK(
|
|
terminator, characterLen_.genre() == Value::Genre::Deferred);
|
|
}
|
|
descriptor.Establish(
|
|
kind_, lengthInChars, nullptr, rank_, nullptr, attribute);
|
|
} else if (cat == TypeCategory::Derived) {
|
|
if (const DerivedType * type{derivedType()}) {
|
|
descriptor.Establish(*type, nullptr, rank_, nullptr, attribute);
|
|
} else { // unlimited polymorphic
|
|
descriptor.Establish(TypeCode{TypeCategory::Derived, 0}, 0, nullptr,
|
|
rank_, nullptr, attribute, true);
|
|
}
|
|
} else {
|
|
descriptor.Establish(cat, kind_, nullptr, rank_, nullptr, attribute);
|
|
}
|
|
if (rank_ && genre_ != Genre::Allocatable && genre_ != Genre::Pointer) {
|
|
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();
|
|
}
|
|
}
|
|
}
|
|
|
|
RT_API_ATTRS void Component::CreatePointerDescriptor(Descriptor &descriptor,
|
|
const Descriptor &container, Terminator &terminator,
|
|
const SubscriptValue *subscripts) const {
|
|
RUNTIME_CHECK(terminator, genre_ == Genre::Data);
|
|
EstablishDescriptor(descriptor, container, terminator);
|
|
if (subscripts) {
|
|
descriptor.set_base_addr(container.Element<char>(subscripts) + offset_);
|
|
} else {
|
|
descriptor.set_base_addr(container.OffsetElement<char>() + offset_);
|
|
}
|
|
descriptor.raw().attribute = CFI_attribute_pointer;
|
|
}
|
|
|
|
RT_API_ATTRS const DerivedType *DerivedType::GetParentType() const {
|
|
if (hasParent_) {
|
|
const Descriptor &compDesc{component()};
|
|
const Component &component{*compDesc.OffsetElement<const Component>()};
|
|
return component.derivedType();
|
|
} else {
|
|
return nullptr;
|
|
}
|
|
}
|
|
|
|
RT_API_ATTRS 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 &&
|
|
Fortran::runtime::memcmp(
|
|
compName, nameDesc.OffsetElement(), compNameLen) == 0) {
|
|
return component;
|
|
}
|
|
}
|
|
const DerivedType *parent{GetParentType()};
|
|
return parent ? parent->FindDataComponent(compName, compNameLen) : nullptr;
|
|
}
|
|
|
|
RT_OFFLOAD_API_GROUP_END
|
|
|
|
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 @ %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](%p) 0x%016jx", offset,
|
|
reinterpret_cast<const void *>(&uints[j]),
|
|
static_cast<std::uintmax_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, uninstantiated_)) {
|
|
std::fputs(" <-- uninstantiated_\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 if (offset == offsetof(DerivedType, specialBitSet_)) {
|
|
std::fputs(" <-- specialBitSet_\n", f);
|
|
} else if (offset == offsetof(DerivedType, hasParent_)) {
|
|
std::fputs(" <-- (flags)\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);
|
|
}
|
|
const Descriptor &specialDesc{special()};
|
|
std::fprintf(
|
|
f, "\n special descriptor (byteSize 0x%zx): ", special_.byteSize);
|
|
specialDesc.Dump(f);
|
|
if (specialDesc.IsAllocated()) {
|
|
std::size_t specials{specialDesc.Elements()};
|
|
for (std::size_t j{0}; j < specials; ++j) {
|
|
std::fprintf(f, " [%3zd] ", j);
|
|
specialDesc.ZeroBasedIndexedElement<SpecialBinding>(j)->Dump(f);
|
|
}
|
|
}
|
|
return f;
|
|
}
|
|
|
|
FILE *Component::Dump(FILE *f) const {
|
|
std::fprintf(f, "Component @ %p:\n", reinterpret_cast<const void *>(this));
|
|
std::fputs(" name: ", f);
|
|
DumpScalarCharacter(f, name(), "Component::name");
|
|
if (genre_ == Genre::Data) {
|
|
std::fputs(" Data ", f);
|
|
} else if (genre_ == Genre::Pointer) {
|
|
std::fputs(" Pointer ", f);
|
|
} else if (genre_ == Genre::Allocatable) {
|
|
std::fputs(" Allocatable", f);
|
|
} else if (genre_ == Genre::Automatic) {
|
|
std::fputs(" Automatic ", f);
|
|
} else {
|
|
std::fprintf(f, " (bad genre 0x%x)", static_cast<int>(genre_));
|
|
}
|
|
std::fprintf(f, " category %d kind %d rank %d offset 0x%zx\n", category_,
|
|
kind_, rank_, static_cast<std::size_t>(offset_));
|
|
if (initialization_) {
|
|
std::fprintf(f, " initialization @ %p:\n",
|
|
reinterpret_cast<const void *>(initialization_));
|
|
for (int j{0}; j < 128; j += sizeof(std::uint64_t)) {
|
|
std::fprintf(f, " [%3d] 0x%016jx\n", j,
|
|
static_cast<std::uintmax_t>(
|
|
*reinterpret_cast<const std::uint64_t *>(initialization_ + j)));
|
|
}
|
|
}
|
|
return f;
|
|
}
|
|
|
|
FILE *SpecialBinding::Dump(FILE *f) const {
|
|
std::fprintf(
|
|
f, "SpecialBinding @ %p:\n", reinterpret_cast<const void *>(this));
|
|
switch (which_) {
|
|
case Which::ScalarAssignment:
|
|
std::fputs(" ScalarAssignment", f);
|
|
break;
|
|
case Which::ElementalAssignment:
|
|
std::fputs(" ElementalAssignment", f);
|
|
break;
|
|
case Which::ReadFormatted:
|
|
std::fputs(" ReadFormatted", f);
|
|
break;
|
|
case Which::ReadUnformatted:
|
|
std::fputs(" ReadUnformatted", f);
|
|
break;
|
|
case Which::WriteFormatted:
|
|
std::fputs(" WriteFormatted", f);
|
|
break;
|
|
case Which::WriteUnformatted:
|
|
std::fputs(" WriteUnformatted", f);
|
|
break;
|
|
case Which::ElementalFinal:
|
|
std::fputs(" ElementalFinal", f);
|
|
break;
|
|
case Which::AssumedRankFinal:
|
|
std::fputs(" AssumedRankFinal", f);
|
|
break;
|
|
default:
|
|
std::fprintf(f, " rank-%d final:",
|
|
static_cast<int>(which_) - static_cast<int>(Which::ScalarFinal));
|
|
break;
|
|
}
|
|
std::fprintf(f, " isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_);
|
|
std::fprintf(f, " isTypeBound: 0x%x\n", isTypeBound_);
|
|
std::fprintf(f, " isArgContiguousSet: 0x%x\n", isArgContiguousSet_);
|
|
std::fprintf(f, " proc: %p\n", reinterpret_cast<void *>(proc_));
|
|
return f;
|
|
}
|
|
|
|
} // namespace Fortran::runtime::typeInfo
|