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