llvm-project/flang/runtime/derived.cpp

//===-- 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