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 "flang/Runtime/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 
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 
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 
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 
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 
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 
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 
62 void RTNAME(PointerAssociateScalar)(Descriptor &pointer, void *target) {
63   pointer.set_base_addr(target);
64 }
65 
66 void RTNAME(PointerAssociate)(Descriptor &pointer, const Descriptor &target) {
67   pointer = target;
68   pointer.raw().attribute = CFI_attribute_pointer;
69 }
70 
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     Dimension &dim{pointer.GetDimension(j)};
80     dim.SetLowerBound(dim.Extent() == 0
81             ? 1
82             : GetInt64(lowerBounds.ZeroBasedIndexedElement<const char>(j),
83                   boundElementBytes, terminator));
84   }
85 }
86 
87 void RTNAME(PointerAssociateRemapping)(Descriptor &pointer,
88     const Descriptor &target, const Descriptor &bounds, const char *sourceFile,
89     int sourceLine) {
90   pointer = target;
91   pointer.raw().attribute = CFI_attribute_pointer;
92   int rank{pointer.rank()};
93   Terminator terminator{sourceFile, sourceLine};
94   SubscriptValue byteStride{/*captured from first dimension*/};
95   std::size_t boundElementBytes{bounds.ElementBytes()};
96   for (int j{0}; j < rank; ++j) {
97     auto &dim{pointer.GetDimension(j)};
98     dim.SetBounds(GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j),
99                       boundElementBytes, terminator),
100         GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j + 1),
101             boundElementBytes, terminator));
102     if (j == 0) {
103       byteStride = dim.ByteStride();
104     } else {
105       dim.SetByteStride(byteStride);
106       byteStride *= dim.Extent();
107     }
108   }
109   if (pointer.Elements() > target.Elements()) {
110     terminator.Crash("PointerAssociateRemapping: too many elements in remapped "
111                      "pointer (%zd > %zd)",
112         pointer.Elements(), target.Elements());
113   }
114 }
115 
116 int RTNAME(PointerAllocate)(Descriptor &pointer, bool hasStat,
117     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
118   Terminator terminator{sourceFile, sourceLine};
119   if (!pointer.IsPointer()) {
120     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
121   }
122   int stat{ReturnError(terminator, pointer.Allocate(), errMsg, hasStat)};
123   if (stat == StatOk) {
124     if (const DescriptorAddendum * addendum{pointer.Addendum()}) {
125       if (const auto *derived{addendum->derivedType()}) {
126         if (!derived->noInitializationNeeded()) {
127           stat = Initialize(pointer, *derived, terminator, hasStat, errMsg);
128         }
129       }
130     }
131   }
132   return stat;
133 }
134 
135 int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat,
136     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
137   Terminator terminator{sourceFile, sourceLine};
138   if (!pointer.IsPointer()) {
139     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
140   }
141   if (!pointer.IsAllocated()) {
142     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
143   }
144   return ReturnError(terminator, pointer.Destroy(true, true), errMsg, hasStat);
145 }
146 
147 bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) {
148   return pointer.raw().base_addr != nullptr;
149 }
150 
151 bool RTNAME(PointerIsAssociatedWith)(
152     const Descriptor &pointer, const Descriptor *target) {
153   if (!target) {
154     return pointer.raw().base_addr != nullptr;
155   }
156   if (!target->raw().base_addr || target->ElementBytes() == 0) {
157     return false;
158   }
159   int rank{pointer.rank()};
160   if (pointer.raw().base_addr != target->raw().base_addr ||
161       pointer.ElementBytes() != target->ElementBytes() ||
162       rank != target->rank()) {
163     return false;
164   }
165   for (int j{0}; j < rank; ++j) {
166     const Dimension &pDim{pointer.GetDimension(j)};
167     const Dimension &tDim{target->GetDimension(j)};
168     auto pExtent{pDim.Extent()};
169     if (pExtent == 0 || pExtent != tDim.Extent() ||
170         (pExtent != 1 && pDim.ByteStride() != tDim.ByteStride())) {
171       return false;
172     }
173   }
174   return true;
175 }
176 
177 // TODO: PointerCheckLengthParameter, PointerAllocateSource
178 
179 } // extern "C"
180 } // namespace Fortran::runtime
181