1 //===-- runtime/pointer.cpp -----------------------------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8
9 #include "pointer.h"
10 #include "derived.h"
11 #include "stat.h"
12 #include "terminator.h"
13 #include "tools.h"
14 #include "type-info.h"
15
16 namespace Fortran::runtime {
17 extern "C" {
18
RTNAME(PointerNullifyIntrinsic)19 void RTNAME(PointerNullifyIntrinsic)(Descriptor &pointer, TypeCategory category,
20 int kind, int rank, int corank) {
21 INTERNAL_CHECK(corank == 0);
22 pointer.Establish(TypeCode{category, kind},
23 Descriptor::BytesFor(category, kind), nullptr, rank, nullptr,
24 CFI_attribute_pointer);
25 }
26
RTNAME(PointerNullifyCharacter)27 void RTNAME(PointerNullifyCharacter)(Descriptor &pointer, SubscriptValue length,
28 int kind, int rank, int corank) {
29 INTERNAL_CHECK(corank == 0);
30 pointer.Establish(
31 kind, length, nullptr, rank, nullptr, CFI_attribute_pointer);
32 }
33
RTNAME(PointerNullifyDerived)34 void RTNAME(PointerNullifyDerived)(Descriptor &pointer,
35 const typeInfo::DerivedType &derivedType, int rank, int corank) {
36 INTERNAL_CHECK(corank == 0);
37 pointer.Establish(derivedType, nullptr, rank, nullptr, CFI_attribute_pointer);
38 }
39
RTNAME(PointerSetBounds)40 void RTNAME(PointerSetBounds)(Descriptor &pointer, int zeroBasedDim,
41 SubscriptValue lower, SubscriptValue upper) {
42 INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < pointer.rank());
43 pointer.GetDimension(zeroBasedDim).SetBounds(lower, upper);
44 // The byte strides are computed when the pointer is allocated.
45 }
46
47 // TODO: PointerSetCoBounds
48
RTNAME(PointerSetDerivedLength)49 void RTNAME(PointerSetDerivedLength)(
50 Descriptor &pointer, int which, SubscriptValue x) {
51 DescriptorAddendum *addendum{pointer.Addendum()};
52 INTERNAL_CHECK(addendum != nullptr);
53 addendum->SetLenParameterValue(which, x);
54 }
55
RTNAME(PointerApplyMold)56 void RTNAME(PointerApplyMold)(Descriptor &pointer, const Descriptor &mold) {
57 pointer = mold;
58 pointer.set_base_addr(nullptr);
59 pointer.raw().attribute = CFI_attribute_pointer;
60 }
61
RTNAME(PointerAssociateScalar)62 void RTNAME(PointerAssociateScalar)(Descriptor &pointer, void *target) {
63 pointer.set_base_addr(target);
64 }
65
RTNAME(PointerAssociate)66 void RTNAME(PointerAssociate)(Descriptor &pointer, const Descriptor &target) {
67 pointer = target;
68 pointer.raw().attribute = CFI_attribute_pointer;
69 }
70
RTNAME(PointerAssociateLowerBounds)71 void RTNAME(PointerAssociateLowerBounds)(Descriptor &pointer,
72 const Descriptor &target, const Descriptor &lowerBounds) {
73 pointer = target;
74 pointer.raw().attribute = CFI_attribute_pointer;
75 int rank{pointer.rank()};
76 Terminator terminator{__FILE__, __LINE__};
77 std::size_t boundElementBytes{lowerBounds.ElementBytes()};
78 for (int j{0}; j < rank; ++j) {
79 pointer.GetDimension(j).SetLowerBound(
80 GetInt64(lowerBounds.ZeroBasedIndexedElement<const char>(j),
81 boundElementBytes, terminator));
82 }
83 }
84
RTNAME(PointerAssociateRemapping)85 void RTNAME(PointerAssociateRemapping)(Descriptor &pointer,
86 const Descriptor &target, const Descriptor &bounds, const char *sourceFile,
87 int sourceLine) {
88 pointer = target;
89 pointer.raw().attribute = CFI_attribute_pointer;
90 int rank{pointer.rank()};
91 Terminator terminator{sourceFile, sourceLine};
92 SubscriptValue byteStride{/*captured from first dimension*/};
93 std::size_t boundElementBytes{bounds.ElementBytes()};
94 for (int j{0}; j < rank; ++j) {
95 auto &dim{pointer.GetDimension(j)};
96 dim.SetBounds(GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j),
97 boundElementBytes, terminator),
98 GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j + 1),
99 boundElementBytes, terminator));
100 if (j == 0) {
101 byteStride = dim.ByteStride();
102 } else {
103 dim.SetByteStride(byteStride);
104 byteStride *= dim.Extent();
105 }
106 }
107 if (pointer.Elements() > target.Elements()) {
108 terminator.Crash("PointerAssociateRemapping: too many elements in remapped "
109 "pointer (%zd > %zd)",
110 pointer.Elements(), target.Elements());
111 }
112 }
113
RTNAME(PointerAllocate)114 int RTNAME(PointerAllocate)(Descriptor &pointer, bool hasStat,
115 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
116 Terminator terminator{sourceFile, sourceLine};
117 if (!pointer.IsPointer()) {
118 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
119 }
120 int stat{ReturnError(terminator, pointer.Allocate(), errMsg, hasStat)};
121 if (stat == StatOk) {
122 if (const DescriptorAddendum * addendum{pointer.Addendum()}) {
123 if (const auto *derived{addendum->derivedType()}) {
124 if (!derived->noInitializationNeeded()) {
125 stat = Initialize(pointer, *derived, terminator, hasStat, errMsg);
126 }
127 }
128 }
129 }
130 return stat;
131 }
132
RTNAME(PointerDeallocate)133 int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat,
134 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
135 Terminator terminator{sourceFile, sourceLine};
136 if (!pointer.IsPointer()) {
137 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
138 }
139 if (!pointer.IsAllocated()) {
140 return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
141 }
142 return ReturnError(terminator, pointer.Destroy(true), errMsg, hasStat);
143 }
144
RTNAME(PointerIsAssociated)145 bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) {
146 return pointer.raw().base_addr != nullptr;
147 }
148
RTNAME(PointerIsAssociatedWith)149 bool RTNAME(PointerIsAssociatedWith)(
150 const Descriptor &pointer, const Descriptor &target) {
151 int rank{pointer.rank()};
152 if (pointer.raw().base_addr != target.raw().base_addr ||
153 pointer.ElementBytes() != target.ElementBytes() ||
154 rank != target.rank()) {
155 return false;
156 }
157 for (int j{0}; j < rank; ++j) {
158 const Dimension &pDim{pointer.GetDimension(j)};
159 const Dimension &tDim{target.GetDimension(j)};
160 if (pDim.Extent() != tDim.Extent() ||
161 pDim.ByteStride() != tDim.ByteStride()) {
162 return false;
163 }
164 }
165 return true;
166 }
167
168 // TODO: PointerCheckLengthParameter, PointerAllocateSource
169
170 } // extern "C"
171 } // namespace Fortran::runtime
172