1 //===-- lib/Evaluate/check-expression.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/Evaluate/check-expression.h"
10 #include "flang/Evaluate/traverse.h"
11 #include "flang/Evaluate/type.h"
12 #include "flang/Semantics/symbol.h"
13 #include "flang/Semantics/tools.h"
14 
15 namespace Fortran::evaluate {
16 
17 // Constant expression predicate IsConstantExpr().
18 // This code determines whether an expression is a "constant expression"
19 // in the sense of section 10.1.12.  This is not the same thing as being
20 // able to fold it (yet) into a known constant value; specifically,
21 // the expression may reference derived type kind parameters whose values
22 // are not yet known.
23 class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
24 public:
25   using Base = AllTraverse<IsConstantExprHelper, true>;
26   IsConstantExprHelper() : Base{*this} {}
27   using Base::operator();
28 
29   template <int KIND> bool operator()(const TypeParamInquiry<KIND> &inq) const {
30     return IsKindTypeParameter(inq.parameter());
31   }
32   bool operator()(const semantics::Symbol &symbol) const {
33     return IsNamedConstant(symbol) || IsImpliedDoIndex(symbol);
34   }
35   bool operator()(const CoarrayRef &) const { return false; }
36   bool operator()(const semantics::ParamValue &param) const {
37     return param.isExplicit() && (*this)(param.GetExplicit());
38   }
39   template <typename T> bool operator()(const FunctionRef<T> &call) const {
40     if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
41       return intrinsic->name == "kind";
42       // TODO: other inquiry intrinsics
43     } else {
44       return false;
45     }
46   }
47 
48   // Forbid integer division by zero in constants.
49   template <int KIND>
50   bool operator()(
51       const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
52     using T = Type<TypeCategory::Integer, KIND>;
53     if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
54       return !divisor->IsZero();
55     } else {
56       return false;
57     }
58   }
59 };
60 
61 template <typename A> bool IsConstantExpr(const A &x) {
62   return IsConstantExprHelper{}(x);
63 }
64 template bool IsConstantExpr(const Expr<SomeType> &);
65 template bool IsConstantExpr(const Expr<SomeInteger> &);
66 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
67 
68 // Object pointer initialization checking predicate IsInitialDataTarget().
69 // This code determines whether an expression is allowable as the static
70 // data address used to initialize a pointer with "=> x".  See C765.
71 struct IsInitialDataTargetHelper
72     : public AllTraverse<IsInitialDataTargetHelper, true> {
73   using Base = AllTraverse<IsInitialDataTargetHelper, true>;
74   using Base::operator();
75   explicit IsInitialDataTargetHelper(parser::ContextualMessages &m)
76       : Base{*this}, messages_{m} {}
77 
78   bool operator()(const BOZLiteralConstant &) const { return false; }
79   bool operator()(const NullPointer &) const { return true; }
80   template <typename T> bool operator()(const Constant<T> &) const {
81     return false;
82   }
83   bool operator()(const semantics::Symbol &symbol) const {
84     const Symbol &ultimate{symbol.GetUltimate()};
85     if (IsAllocatable(ultimate)) {
86       messages_.Say(
87           "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
88           ultimate.name());
89     } else if (ultimate.Corank() > 0) {
90       messages_.Say(
91           "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
92           ultimate.name());
93     } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
94       messages_.Say(
95           "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
96           ultimate.name());
97     } else if (!IsSaved(ultimate)) {
98       messages_.Say(
99           "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
100           ultimate.name());
101     }
102     return true;
103   }
104   bool operator()(const StaticDataObject &) const { return false; }
105   template <int KIND> bool operator()(const TypeParamInquiry<KIND> &) const {
106     return false;
107   }
108   bool operator()(const Triplet &x) const {
109     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
110         IsConstantExpr(x.stride());
111   }
112   bool operator()(const Subscript &x) const {
113     return std::visit(common::visitors{
114                           [&](const Triplet &t) { return (*this)(t); },
115                           [&](const auto &y) {
116                             return y.value().Rank() == 0 &&
117                                 IsConstantExpr(y.value());
118                           },
119                       },
120         x.u);
121   }
122   bool operator()(const CoarrayRef &) const { return false; }
123   bool operator()(const Substring &x) const {
124     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
125         (*this)(x.parent());
126   }
127   bool operator()(const DescriptorInquiry &) const { return false; }
128   template <typename T> bool operator()(const ArrayConstructor<T> &) const {
129     return false;
130   }
131   bool operator()(const StructureConstructor &) const { return false; }
132   template <typename T> bool operator()(const FunctionRef<T> &) {
133     return false;
134   }
135   template <typename D, typename R, typename... O>
136   bool operator()(const Operation<D, R, O...> &) const {
137     return false;
138   }
139   template <typename T> bool operator()(const Parentheses<T> &x) const {
140     return (*this)(x.left());
141   }
142   bool operator()(const Relational<SomeType> &) const { return false; }
143 
144 private:
145   parser::ContextualMessages &messages_;
146 };
147 
148 bool IsInitialDataTarget(
149     const Expr<SomeType> &x, parser::ContextualMessages &messages) {
150   return IsInitialDataTargetHelper{messages}(x);
151 }
152 
153 // Specification expression validation (10.1.11(2), C1010)
154 class CheckSpecificationExprHelper
155     : public AnyTraverse<CheckSpecificationExprHelper,
156           std::optional<std::string>> {
157 public:
158   using Result = std::optional<std::string>;
159   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
160   explicit CheckSpecificationExprHelper(const semantics::Scope &s)
161       : Base{*this}, scope_{s} {}
162   using Base::operator();
163 
164   Result operator()(const ProcedureDesignator &) const {
165     return "dummy procedure argument";
166   }
167   Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
168 
169   Result operator()(const semantics::Symbol &symbol) const {
170     if (semantics::IsNamedConstant(symbol)) {
171       return std::nullopt;
172     } else if (symbol.IsDummy()) {
173       if (symbol.attrs().test(semantics::Attr::OPTIONAL)) {
174         return "reference to OPTIONAL dummy argument '"s +
175             symbol.name().ToString() + "'";
176       } else if (symbol.attrs().test(semantics::Attr::INTENT_OUT)) {
177         return "reference to INTENT(OUT) dummy argument '"s +
178             symbol.name().ToString() + "'";
179       } else if (symbol.has<semantics::ObjectEntityDetails>()) {
180         return std::nullopt;
181       } else {
182         return "dummy procedure argument";
183       }
184     } else if (symbol.has<semantics::UseDetails>() ||
185         symbol.has<semantics::HostAssocDetails>() ||
186         symbol.owner().kind() == semantics::Scope::Kind::Module) {
187       return std::nullopt;
188     } else if (const auto *object{
189                    symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
190       // TODO: what about EQUIVALENCE with data in COMMON?
191       // TODO: does this work for blank COMMON?
192       if (object->commonBlock()) {
193         return std::nullopt;
194       }
195     }
196     for (const semantics::Scope *s{&scope_}; !s->IsGlobal();) {
197       s = &s->parent();
198       if (s == &symbol.owner()) {
199         return std::nullopt;
200       }
201     }
202     return "reference to local entity '"s + symbol.name().ToString() + "'";
203   }
204 
205   Result operator()(const Component &x) const {
206     // Don't look at the component symbol.
207     return (*this)(x.base());
208   }
209   Result operator()(const DescriptorInquiry &) const {
210     // Subtle: Uses of SIZE(), LBOUND(), &c. that are valid in specification
211     // expressions will have been converted to expressions over descriptor
212     // inquiries by Fold().
213     return std::nullopt;
214   }
215 
216   template <typename T> Result operator()(const FunctionRef<T> &x) const {
217     if (const auto *symbol{x.proc().GetSymbol()}) {
218       if (!semantics::IsPureProcedure(*symbol)) {
219         return "reference to impure function '"s + symbol->name().ToString() +
220             "'";
221       }
222       // TODO: other checks for standard module procedures
223     } else {
224       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
225       if (intrin.name == "present") {
226         return std::nullopt; // no need to check argument(s)
227       }
228       if (IsConstantExpr(x)) {
229         // inquiry functions may not need to check argument(s)
230         return std::nullopt;
231       }
232     }
233     return (*this)(x.arguments());
234   }
235 
236 private:
237   const semantics::Scope &scope_;
238 };
239 
240 template <typename A>
241 void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages,
242     const semantics::Scope &scope) {
243   if (auto why{CheckSpecificationExprHelper{scope}(x)}) {
244     messages.Say("Invalid specification expression: %s"_err_en_US, *why);
245   }
246 }
247 
248 template void CheckSpecificationExpr(const Expr<SomeType> &,
249     parser::ContextualMessages &, const semantics::Scope &);
250 template void CheckSpecificationExpr(const Expr<SomeInteger> &,
251     parser::ContextualMessages &, const semantics::Scope &);
252 template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
253     parser::ContextualMessages &, const semantics::Scope &);
254 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
255     parser::ContextualMessages &, const semantics::Scope &);
256 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
257     parser::ContextualMessages &, const semantics::Scope &);
258 template void CheckSpecificationExpr(
259     const std::optional<Expr<SubscriptInteger>> &, parser::ContextualMessages &,
260     const semantics::Scope &);
261 
262 // IsSimplyContiguous() -- 9.5.4
263 class IsSimplyContiguousHelper
264     : public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> {
265 public:
266   using Result = std::optional<bool>; // tri-state
267   using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
268   explicit IsSimplyContiguousHelper(const IntrinsicProcTable &t)
269       : Base{*this}, table_{t} {}
270   using Base::operator();
271 
272   Result operator()(const semantics::Symbol &symbol) const {
273     if (symbol.attrs().test(semantics::Attr::CONTIGUOUS) ||
274         symbol.Rank() == 0) {
275       return true;
276     } else if (semantics::IsPointer(symbol)) {
277       return false;
278     } else if (const auto *details{
279                    symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
280       // N.B. ALLOCATABLEs are deferred shape, not assumed, and
281       // are obviously contiguous.
282       return !details->IsAssumedShape() && !details->IsAssumedRank();
283     } else {
284       return false;
285     }
286   }
287 
288   Result operator()(const ArrayRef &x) const {
289     const auto &symbol{x.GetLastSymbol()};
290     if (!(*this)(symbol)) {
291       return false;
292     } else if (auto rank{CheckSubscripts(x.subscript())}) {
293       // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is
294       return *rank > 0 || x.Rank() == 0;
295     } else {
296       return false;
297     }
298   }
299   Result operator()(const CoarrayRef &x) const {
300     return CheckSubscripts(x.subscript()).has_value();
301   }
302   Result operator()(const Component &x) const {
303     return x.base().Rank() == 0 && (*this)(x.GetLastSymbol());
304   }
305   Result operator()(const ComplexPart &) const { return false; }
306   Result operator()(const Substring &) const { return false; }
307 
308   template <typename T> Result operator()(const FunctionRef<T> &x) const {
309     if (auto chars{
310             characteristics::Procedure::Characterize(x.proc(), table_)}) {
311       if (chars->functionResult) {
312         const auto &result{*chars->functionResult};
313         return !result.IsProcedurePointer() &&
314             result.attrs.test(characteristics::FunctionResult::Attr::Pointer) &&
315             result.attrs.test(
316                 characteristics::FunctionResult::Attr::Contiguous);
317       }
318     }
319     return false;
320   }
321 
322 private:
323   // If the subscripts can possibly be on a simply-contiguous array reference,
324   // return the rank.
325   static std::optional<int> CheckSubscripts(
326       const std::vector<Subscript> &subscript) {
327     bool anyTriplet{false};
328     int rank{0};
329     for (auto j{subscript.size()}; j-- > 0;) {
330       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
331         if (!triplet->IsStrideOne()) {
332           return std::nullopt;
333         } else if (anyTriplet) {
334           if (triplet->lower() || triplet->upper()) {
335             // all triplets before the last one must be just ":"
336             return std::nullopt;
337           }
338         } else {
339           anyTriplet = true;
340         }
341         ++rank;
342       } else if (anyTriplet || subscript[j].Rank() > 0) {
343         return std::nullopt;
344       }
345     }
346     return rank;
347   }
348 
349   const IntrinsicProcTable &table_;
350 };
351 
352 template <typename A>
353 bool IsSimplyContiguous(const A &x, const IntrinsicProcTable &table) {
354   if (IsVariable(x)) {
355     auto known{IsSimplyContiguousHelper{table}(x)};
356     return known && *known;
357   } else {
358     return true; // not a variable
359   }
360 }
361 
362 template bool IsSimplyContiguous(
363     const Expr<SomeType> &, const IntrinsicProcTable &);
364 
365 } // namespace Fortran::evaluate
366