//===-- runtime/pointer.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/pointer.h" #include "assign-impl.h" #include "derived.h" #include "stat.h" #include "terminator.h" #include "tools.h" #include "type-info.h" namespace Fortran::runtime { extern "C" { RT_EXT_API_GROUP_BEGIN void RTDEF(PointerNullifyIntrinsic)(Descriptor &pointer, TypeCategory category, int kind, int rank, int corank) { INTERNAL_CHECK(corank == 0); pointer.Establish(TypeCode{category, kind}, Descriptor::BytesFor(category, kind), nullptr, rank, nullptr, CFI_attribute_pointer); } void RTDEF(PointerNullifyCharacter)(Descriptor &pointer, SubscriptValue length, int kind, int rank, int corank) { INTERNAL_CHECK(corank == 0); pointer.Establish( kind, length, nullptr, rank, nullptr, CFI_attribute_pointer); } void RTDEF(PointerNullifyDerived)(Descriptor &pointer, const typeInfo::DerivedType &derivedType, int rank, int corank) { INTERNAL_CHECK(corank == 0); pointer.Establish(derivedType, nullptr, rank, nullptr, CFI_attribute_pointer); } void RTDEF(PointerSetBounds)(Descriptor &pointer, int zeroBasedDim, SubscriptValue lower, SubscriptValue upper) { INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < pointer.rank()); pointer.GetDimension(zeroBasedDim).SetBounds(lower, upper); // The byte strides are computed when the pointer is allocated. } // TODO: PointerSetCoBounds void RTDEF(PointerSetDerivedLength)( Descriptor &pointer, int which, SubscriptValue x) { DescriptorAddendum *addendum{pointer.Addendum()}; INTERNAL_CHECK(addendum != nullptr); addendum->SetLenParameterValue(which, x); } void RTDEF(PointerApplyMold)( Descriptor &pointer, const Descriptor &mold, int rank) { pointer.ApplyMold(mold, rank); } void RTDEF(PointerAssociateScalar)(Descriptor &pointer, void *target) { pointer.set_base_addr(target); } void RTDEF(PointerAssociate)(Descriptor &pointer, const Descriptor &target) { pointer = target; pointer.raw().attribute = CFI_attribute_pointer; } void RTDEF(PointerAssociateLowerBounds)(Descriptor &pointer, const Descriptor &target, const Descriptor &lowerBounds) { pointer = target; pointer.raw().attribute = CFI_attribute_pointer; int rank{pointer.rank()}; Terminator terminator{__FILE__, __LINE__}; std::size_t boundElementBytes{lowerBounds.ElementBytes()}; for (int j{0}; j < rank; ++j) { Dimension &dim{pointer.GetDimension(j)}; dim.SetLowerBound(dim.Extent() == 0 ? 1 : GetInt64(lowerBounds.ZeroBasedIndexedElement(j), boundElementBytes, terminator)); } } void RTDEF(PointerAssociateRemapping)(Descriptor &pointer, const Descriptor &target, const Descriptor &bounds, const char *sourceFile, int sourceLine) { pointer = target; pointer.raw().attribute = CFI_attribute_pointer; Terminator terminator{sourceFile, sourceLine}; SubscriptValue byteStride{/*captured from first dimension*/}; std::size_t boundElementBytes{bounds.ElementBytes()}; std::size_t boundsRank{ static_cast(bounds.GetDimension(1).Extent())}; pointer.raw().rank = boundsRank; for (unsigned j{0}; j < boundsRank; ++j) { auto &dim{pointer.GetDimension(j)}; dim.SetBounds(GetInt64(bounds.ZeroBasedIndexedElement(2 * j), boundElementBytes, terminator), GetInt64(bounds.ZeroBasedIndexedElement(2 * j + 1), boundElementBytes, terminator)); if (j == 0) { byteStride = dim.ByteStride() * dim.Extent(); } else { dim.SetByteStride(byteStride); byteStride *= dim.Extent(); } } if (pointer.Elements() > target.Elements()) { terminator.Crash("PointerAssociateRemapping: too many elements in remapped " "pointer (%zd > %zd)", pointer.Elements(), target.Elements()); } if (auto *pointerAddendum{pointer.Addendum()}) { if (const auto *targetAddendum{target.Addendum()}) { if (const auto *derived{targetAddendum->derivedType()}) { pointerAddendum->set_derivedType(derived); } } } } int RTDEF(PointerAllocate)(Descriptor &pointer, bool hasStat, const Descriptor *errMsg, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; if (!pointer.IsPointer()) { return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); } int stat{ReturnError(terminator, pointer.Allocate(), errMsg, hasStat)}; if (stat == StatOk) { if (const DescriptorAddendum * addendum{pointer.Addendum()}) { if (const auto *derived{addendum->derivedType()}) { if (!derived->noInitializationNeeded()) { stat = Initialize(pointer, *derived, terminator, hasStat, errMsg); } } } } return stat; } int RTDEF(PointerAllocateSource)(Descriptor &pointer, const Descriptor &source, bool hasStat, const Descriptor *errMsg, const char *sourceFile, int sourceLine) { int stat{RTNAME(PointerAllocate)( pointer, hasStat, errMsg, sourceFile, sourceLine)}; if (stat == StatOk) { Terminator terminator{sourceFile, sourceLine}; DoFromSourceAssign(pointer, source, terminator); } return stat; } int RTDEF(PointerDeallocate)(Descriptor &pointer, bool hasStat, const Descriptor *errMsg, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; if (!pointer.IsPointer()) { return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); } if (!pointer.IsAllocated()) { return ReturnError(terminator, StatBaseNull, errMsg, hasStat); } return ReturnError(terminator, pointer.Destroy(/*finalize=*/true, /*destroyPointers=*/true, &terminator), errMsg, hasStat); } int RTDEF(PointerDeallocatePolymorphic)(Descriptor &pointer, const typeInfo::DerivedType *derivedType, bool hasStat, const Descriptor *errMsg, const char *sourceFile, int sourceLine) { int stat{RTNAME(PointerDeallocate)( pointer, hasStat, errMsg, sourceFile, sourceLine)}; if (stat == StatOk) { if (DescriptorAddendum * addendum{pointer.Addendum()}) { addendum->set_derivedType(derivedType); pointer.raw().type = derivedType ? CFI_type_struct : CFI_type_other; } else { // Unlimited polymorphic descriptors initialized with // PointerNullifyIntrinsic do not have an addendum. Make sure the // derivedType is null in that case. INTERNAL_CHECK(!derivedType); pointer.raw().type = CFI_type_other; } } return stat; } bool RTDEF(PointerIsAssociated)(const Descriptor &pointer) { return pointer.raw().base_addr != nullptr; } bool RTDEF(PointerIsAssociatedWith)( const Descriptor &pointer, const Descriptor *target) { if (!target) { return pointer.raw().base_addr != nullptr; } if (!target->raw().base_addr || (target->raw().type != CFI_type_struct && target->ElementBytes() == 0)) { return false; } int rank{pointer.rank()}; if (pointer.raw().base_addr != target->raw().base_addr || pointer.ElementBytes() != target->ElementBytes() || rank != target->rank()) { return false; } for (int j{0}; j < rank; ++j) { const Dimension &pDim{pointer.GetDimension(j)}; const Dimension &tDim{target->GetDimension(j)}; auto pExtent{pDim.Extent()}; if (pExtent == 0 || pExtent != tDim.Extent() || (pExtent != 1 && pDim.ByteStride() != tDim.ByteStride())) { return false; } } return true; } // TODO: PointerCheckLengthParameter RT_EXT_API_GROUP_END } // extern "C" } // namespace Fortran::runtime