01e8e50ce3
As mentioned in section 7.3.2.3 note 7, The dynamic type of an unallocated allocatable object or a disassociated pointer is the same as its declared type. This patch adds two function to the runtime: - `PointerDeallocatePolymorphic` - `AllocatableDeallocatePolymorphic` These two functions take a DerivedTypeDesc pointer of the declared type. The lowering is updated accordingly to call these functions for polymorphic and unlimited polyrmophic entities. For unlimited polymorphic entities, the dynamic type is set to nullptr when the entity is on an unallocated or disassociated state. Reviewed By: PeteSteinfeld, klausler Differential Revision: https://reviews.llvm.org/D141519
131 lines
4.6 KiB
C++
131 lines
4.6 KiB
C++
//===-- runtime/allocatable.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 "flang/Runtime/allocatable.h"
|
|
#include "derived.h"
|
|
#include "stat.h"
|
|
#include "terminator.h"
|
|
#include "type-info.h"
|
|
#include "flang/Runtime/assign.h"
|
|
|
|
namespace Fortran::runtime {
|
|
extern "C" {
|
|
|
|
void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor,
|
|
TypeCategory category, int kind, int rank, int corank) {
|
|
INTERNAL_CHECK(corank == 0);
|
|
descriptor.Establish(TypeCode{category, kind},
|
|
Descriptor::BytesFor(category, kind), nullptr, rank, nullptr,
|
|
CFI_attribute_allocatable);
|
|
}
|
|
|
|
void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor,
|
|
SubscriptValue length, int kind, int rank, int corank) {
|
|
INTERNAL_CHECK(corank == 0);
|
|
descriptor.Establish(
|
|
kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable);
|
|
}
|
|
|
|
void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
|
|
const typeInfo::DerivedType &derivedType, int rank, int corank) {
|
|
INTERNAL_CHECK(corank == 0);
|
|
descriptor.Establish(
|
|
derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
|
|
}
|
|
|
|
int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
|
|
bool /*hasStat*/, const Descriptor * /*errMsg*/,
|
|
const char * /*sourceFile*/, int /*sourceLine*/) {
|
|
INTERNAL_CHECK(false); // TODO: MoveAlloc is not yet implemented
|
|
return StatOk;
|
|
}
|
|
|
|
void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,
|
|
SubscriptValue lower, SubscriptValue upper) {
|
|
INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());
|
|
descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);
|
|
// The byte strides are computed when the object is allocated.
|
|
}
|
|
|
|
void RTNAME(AllocatableSetDerivedLength)(
|
|
Descriptor &descriptor, int which, SubscriptValue x) {
|
|
DescriptorAddendum *addendum{descriptor.Addendum()};
|
|
INTERNAL_CHECK(addendum != nullptr);
|
|
addendum->SetLenParameterValue(which, x);
|
|
}
|
|
|
|
void RTNAME(AllocatableApplyMold)(
|
|
Descriptor &descriptor, const Descriptor &mold) {
|
|
descriptor = mold;
|
|
descriptor.set_base_addr(nullptr);
|
|
descriptor.raw().attribute = CFI_attribute_allocatable;
|
|
}
|
|
|
|
int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat,
|
|
const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
|
|
Terminator terminator{sourceFile, sourceLine};
|
|
if (!descriptor.IsAllocatable()) {
|
|
return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
|
|
}
|
|
if (descriptor.IsAllocated()) {
|
|
return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);
|
|
}
|
|
int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)};
|
|
if (stat == StatOk) {
|
|
if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
|
|
if (const auto *derived{addendum->derivedType()}) {
|
|
if (!derived->noInitializationNeeded()) {
|
|
stat = Initialize(descriptor, *derived, terminator, hasStat, errMsg);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return stat;
|
|
}
|
|
|
|
int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
|
|
const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
|
|
Terminator terminator{sourceFile, sourceLine};
|
|
if (!descriptor.IsAllocatable()) {
|
|
return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
|
|
}
|
|
if (!descriptor.IsAllocated()) {
|
|
return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
|
|
}
|
|
return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat);
|
|
}
|
|
|
|
int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
|
|
const typeInfo::DerivedType *derivedType, bool hasStat,
|
|
const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
|
|
int stat{RTNAME(AllocatableDeallocate)(
|
|
descriptor, hasStat, errMsg, sourceFile, sourceLine)};
|
|
if (stat == StatOk) {
|
|
DescriptorAddendum *addendum{descriptor.Addendum()};
|
|
INTERNAL_CHECK(addendum != nullptr);
|
|
addendum->set_derivedType(derivedType);
|
|
}
|
|
return stat;
|
|
}
|
|
|
|
void RTNAME(AllocatableDeallocateNoFinal)(
|
|
Descriptor &descriptor, const char *sourceFile, int sourceLine) {
|
|
Terminator terminator{sourceFile, sourceLine};
|
|
if (!descriptor.IsAllocatable()) {
|
|
ReturnError(terminator, StatInvalidDescriptor);
|
|
} else if (!descriptor.IsAllocated()) {
|
|
ReturnError(terminator, StatBaseNull);
|
|
} else {
|
|
ReturnError(terminator, descriptor.Destroy(false));
|
|
}
|
|
}
|
|
|
|
// TODO: AllocatableCheckLengthParameter, AllocatableAllocateSource
|
|
}
|
|
} // namespace Fortran::runtime
|