c1db35f0c2
Define APIs, naively implement, and add basic sanity unit tests for the transformational intrinsic functions CSHIFT, EOSHIFT, PACK, SPREAD, TRANSPOSE, and UNPACK. These are the remaining transformational intrinsic functions that rearrange data without regard to type (except for default boundary values in EOSHIFT); RESHAPE was already in place as a stress test for the runtime's descriptor handling facilities. Code is in place to create copies of allocatable/automatic components when transforming arrays of derived type, but it won't do anything until we have derived type information being passed to the runtime from the frontend. Differential Revision: https://reviews.llvm.org/D102857
81 lines
3.0 KiB
C++
81 lines
3.0 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 "allocatable.h"
|
|
#include "stat.h"
|
|
#include "terminator.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);
|
|
}
|
|
|
|
void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {
|
|
INTERNAL_CHECK(false); // AllocatableAssign is not yet implemented
|
|
}
|
|
|
|
int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
|
|
bool /*hasStat*/, const Descriptor * /*errMsg*/,
|
|
const char * /*sourceFile*/, int /*sourceLine*/) {
|
|
INTERNAL_CHECK(false); // 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.
|
|
}
|
|
|
|
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);
|
|
}
|
|
return ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat);
|
|
}
|
|
|
|
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.Deallocate(), errMsg, hasStat);
|
|
}
|
|
}
|
|
} // namespace Fortran::runtime
|