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     pointer.GetDimension(j).SetLowerBound(
80         GetInt64(lowerBounds.ZeroBasedIndexedElement<const char>(j),
81             boundElementBytes, terminator));
82   }
83 }
84 
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 
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 
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 
145 bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) {
146   return pointer.raw().base_addr != nullptr;
147 }
148 
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