xref: /llvm-project/flang/lib/Evaluate/check-expression.cpp (revision 4171f80d5416eccbeebe8864410d576d7dc61eaa) 
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/intrinsics.h"
11 #include "flang/Evaluate/traverse.h"
12 #include "flang/Evaluate/type.h"
13 #include "flang/Semantics/symbol.h"
14 #include "flang/Semantics/tools.h"
15 #include <set>
16 #include <string>
17 
18 namespace Fortran::evaluate {
19 
20 // Constant expression predicate IsConstantExpr().
21 // This code determines whether an expression is a "constant expression"
22 // in the sense of section 10.1.12.  This is not the same thing as being
23 // able to fold it (yet) into a known constant value; specifically,
24 // the expression may reference derived type kind parameters whose values
25 // are not yet known.
26 class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
27 public:
28   using Base = AllTraverse<IsConstantExprHelper, true>;
29   IsConstantExprHelper() : Base{*this} {}
30   using Base::operator();
31 
32   template <int KIND> bool operator()(const TypeParamInquiry<KIND> &inq) const {
33     return IsKindTypeParameter(inq.parameter());
34   }
35   bool operator()(const semantics::Symbol &symbol) const {
36     const auto &ultimate{symbol.GetUltimate()};
37     return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
38         IsInitialProcedureTarget(ultimate);
39   }
40   bool operator()(const CoarrayRef &) const { return false; }
41   bool operator()(const semantics::ParamValue &param) const {
42     return param.isExplicit() && (*this)(param.GetExplicit());
43   }
44   template <typename T> bool operator()(const FunctionRef<T> &call) const {
45     if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
46       return intrinsic->name == "kind";
47       // TODO: other inquiry intrinsics
48     } else {
49       return false;
50     }
51   }
52   bool operator()(const StructureConstructor &constructor) const {
53     for (const auto &[symRef, expr] : constructor) {
54       if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
55         return false;
56       }
57     }
58     return true;
59   }
60   bool operator()(const Component &component) const {
61     return (*this)(component.base());
62   }
63   // Forbid integer division by zero in constants.
64   template <int KIND>
65   bool operator()(
66       const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
67     using T = Type<TypeCategory::Integer, KIND>;
68     if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
69       return !divisor->IsZero() && (*this)(division.left());
70     } else {
71       return false;
72     }
73   }
74 
75   bool operator()(const Constant<SomeDerived> &) const { return true; }
76 
77 private:
78   bool IsConstantStructureConstructorComponent(
79       const Symbol &component, const Expr<SomeType> &expr) const {
80     if (IsAllocatable(component)) {
81       return IsNullPointer(expr);
82     } else if (IsPointer(component)) {
83       return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
84           IsInitialProcedureTarget(expr);
85     } else {
86       return (*this)(expr);
87     }
88   }
89 };
90 
91 template <typename A> bool IsConstantExpr(const A &x) {
92   return IsConstantExprHelper{}(x);
93 }
94 template bool IsConstantExpr(const Expr<SomeType> &);
95 template bool IsConstantExpr(const Expr<SomeInteger> &);
96 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
97 template bool IsConstantExpr(const StructureConstructor &);
98 
99 // Object pointer initialization checking predicate IsInitialDataTarget().
100 // This code determines whether an expression is allowable as the static
101 // data address used to initialize a pointer with "=> x".  See C765.
102 class IsInitialDataTargetHelper
103     : public AllTraverse<IsInitialDataTargetHelper, true> {
104 public:
105   using Base = AllTraverse<IsInitialDataTargetHelper, true>;
106   using Base::operator();
107   explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
108       : Base{*this}, messages_{m} {}
109 
110   bool emittedMessage() const { return emittedMessage_; }
111 
112   bool operator()(const BOZLiteralConstant &) const { return false; }
113   bool operator()(const NullPointer &) const { return true; }
114   template <typename T> bool operator()(const Constant<T> &) const {
115     return false;
116   }
117   bool operator()(const semantics::Symbol &symbol) {
118     const Symbol &ultimate{symbol.GetUltimate()};
119     if (IsAllocatable(ultimate)) {
120       if (messages_) {
121         messages_->Say(
122             "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
123             ultimate.name());
124         emittedMessage_ = true;
125       }
126       return false;
127     } else if (ultimate.Corank() > 0) {
128       if (messages_) {
129         messages_->Say(
130             "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
131             ultimate.name());
132         emittedMessage_ = true;
133       }
134       return false;
135     } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
136       if (messages_) {
137         messages_->Say(
138             "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
139             ultimate.name());
140         emittedMessage_ = true;
141       }
142       return false;
143     } else if (!IsSaved(ultimate)) {
144       if (messages_) {
145         messages_->Say(
146             "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
147             ultimate.name());
148         emittedMessage_ = true;
149       }
150       return false;
151     }
152     return true;
153   }
154   bool operator()(const StaticDataObject &) const { return false; }
155   template <int KIND> bool operator()(const TypeParamInquiry<KIND> &) const {
156     return false;
157   }
158   bool operator()(const Triplet &x) const {
159     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
160         IsConstantExpr(x.stride());
161   }
162   bool operator()(const Subscript &x) const {
163     return std::visit(common::visitors{
164                           [&](const Triplet &t) { return (*this)(t); },
165                           [&](const auto &y) {
166                             return y.value().Rank() == 0 &&
167                                 IsConstantExpr(y.value());
168                           },
169                       },
170         x.u);
171   }
172   bool operator()(const CoarrayRef &) const { return false; }
173   bool operator()(const Substring &x) const {
174     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
175         (*this)(x.parent());
176   }
177   bool operator()(const DescriptorInquiry &) const { return false; }
178   template <typename T> bool operator()(const ArrayConstructor<T> &) const {
179     return false;
180   }
181   bool operator()(const StructureConstructor &) const { return false; }
182   template <typename T> bool operator()(const FunctionRef<T> &) {
183     return false;
184   }
185   template <typename D, typename R, typename... O>
186   bool operator()(const Operation<D, R, O...> &) const {
187     return false;
188   }
189   template <typename T> bool operator()(const Parentheses<T> &x) const {
190     return (*this)(x.left());
191   }
192   bool operator()(const Relational<SomeType> &) const { return false; }
193 
194 private:
195   parser::ContextualMessages *messages_;
196   bool emittedMessage_{false};
197 };
198 
199 bool IsInitialDataTarget(
200     const Expr<SomeType> &x, parser::ContextualMessages *messages) {
201   IsInitialDataTargetHelper helper{messages};
202   bool result{helper(x)};
203   if (!result && messages && !helper.emittedMessage()) {
204     messages->Say(
205         "An initial data target must be a designator with constant subscripts"_err_en_US);
206   }
207   return result;
208 }
209 
210 bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
211   const auto &ultimate{symbol.GetUltimate()};
212   return std::visit(
213       common::visitors{
214           [](const semantics::SubprogramDetails &) { return true; },
215           [](const semantics::SubprogramNameDetails &) { return true; },
216           [&](const semantics::ProcEntityDetails &proc) {
217             return !semantics::IsPointer(ultimate) && !proc.isDummy();
218           },
219           [](const auto &) { return false; },
220       },
221       ultimate.details());
222 }
223 
224 bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
225   if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
226     return !intrin->isRestrictedSpecific;
227   } else if (proc.GetComponent()) {
228     return false;
229   } else {
230     return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
231   }
232 }
233 
234 bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
235   if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
236     return IsInitialProcedureTarget(*proc);
237   } else {
238     return IsNullPointer(expr);
239   }
240 }
241 
242 // Specification expression validation (10.1.11(2), C1010)
243 class CheckSpecificationExprHelper
244     : public AnyTraverse<CheckSpecificationExprHelper,
245           std::optional<std::string>> {
246 public:
247   using Result = std::optional<std::string>;
248   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
249   explicit CheckSpecificationExprHelper(
250       const semantics::Scope &s, const IntrinsicProcTable &table)
251       : Base{*this}, scope_{s}, table_{table} {}
252   using Base::operator();
253 
254   Result operator()(const ProcedureDesignator &) const {
255     return "dummy procedure argument";
256   }
257   Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
258 
259   Result operator()(const semantics::Symbol &symbol) const {
260     if (semantics::IsNamedConstant(symbol)) {
261       return std::nullopt;
262     } else if (scope_.IsDerivedType() && IsVariableName(symbol)) { // C750, C754
263       return "derived type component or type parameter value not allowed to "
264              "reference variable '"s +
265           symbol.name().ToString() + "'";
266     } else if (IsDummy(symbol)) {
267       if (symbol.attrs().test(semantics::Attr::OPTIONAL)) {
268         return "reference to OPTIONAL dummy argument '"s +
269             symbol.name().ToString() + "'";
270       } else if (symbol.attrs().test(semantics::Attr::INTENT_OUT)) {
271         return "reference to INTENT(OUT) dummy argument '"s +
272             symbol.name().ToString() + "'";
273       } else if (symbol.has<semantics::ObjectEntityDetails>()) {
274         return std::nullopt;
275       } else {
276         return "dummy procedure argument";
277       }
278     } else if (symbol.has<semantics::UseDetails>() ||
279         symbol.has<semantics::HostAssocDetails>() ||
280         symbol.owner().kind() == semantics::Scope::Kind::Module) {
281       return std::nullopt;
282     } else if (const auto *object{
283                    symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
284       // TODO: what about EQUIVALENCE with data in COMMON?
285       // TODO: does this work for blank COMMON?
286       if (object->commonBlock()) {
287         return std::nullopt;
288       }
289     }
290     for (const semantics::Scope *s{&scope_}; !s->IsGlobal();) {
291       s = &s->parent();
292       if (s == &symbol.owner()) {
293         return std::nullopt;
294       }
295     }
296     return "reference to local entity '"s + symbol.name().ToString() + "'";
297   }
298 
299   Result operator()(const Component &x) const {
300     // Don't look at the component symbol.
301     return (*this)(x.base());
302   }
303   Result operator()(const DescriptorInquiry &) const {
304     // Subtle: Uses of SIZE(), LBOUND(), &c. that are valid in specification
305     // expressions will have been converted to expressions over descriptor
306     // inquiries by Fold().
307     return std::nullopt;
308   }
309 
310   template <int KIND>
311   Result operator()(const TypeParamInquiry<KIND> &inq) const {
312     if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
313         inq.parameter().owner() != scope_) { // C750, C754
314       return "non-constant reference to a type parameter inquiry not "
315              "allowed for derived type components or type parameter values";
316     }
317     return std::nullopt;
318   }
319 
320   template <typename T> Result operator()(const FunctionRef<T> &x) const {
321     if (const auto *symbol{x.proc().GetSymbol()}) {
322       if (!semantics::IsPureProcedure(*symbol)) {
323         return "reference to impure function '"s + symbol->name().ToString() +
324             "'";
325       }
326       if (semantics::IsStmtFunction(*symbol)) {
327         return "reference to statement function '"s +
328             symbol->name().ToString() + "'";
329       }
330       if (scope_.IsDerivedType()) { // C750, C754
331         return "reference to function '"s + symbol->name().ToString() +
332             "' not allowed for derived type components or type parameter"
333             " values";
334       }
335       // TODO: other checks for standard module procedures
336     } else {
337       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
338       if (scope_.IsDerivedType()) { // C750, C754
339         if ((table_.IsIntrinsic(intrin.name) &&
340                 badIntrinsicsForComponents_.find(intrin.name) !=
341                     badIntrinsicsForComponents_.end()) ||
342             IsProhibitedFunction(intrin.name)) {
343           return "reference to intrinsic '"s + intrin.name +
344               "' not allowed for derived type components or type parameter"
345               " values";
346         }
347         if (table_.GetIntrinsicClass(intrin.name) ==
348                 IntrinsicClass::inquiryFunction &&
349             !IsConstantExpr(x)) {
350           return "non-constant reference to inquiry intrinsic '"s +
351               intrin.name +
352               "' not allowed for derived type components or type"
353               " parameter values";
354         }
355       } else if (intrin.name == "present") {
356         return std::nullopt; // no need to check argument(s)
357       }
358       if (IsConstantExpr(x)) {
359         // inquiry functions may not need to check argument(s)
360         return std::nullopt;
361       }
362     }
363     return (*this)(x.arguments());
364   }
365 
366 private:
367   const semantics::Scope &scope_;
368   const IntrinsicProcTable &table_;
369   const std::set<std::string> badIntrinsicsForComponents_{
370       "allocated", "associated", "extends_type_of", "present", "same_type_as"};
371   static bool IsProhibitedFunction(std::string name) { return false; }
372 };
373 
374 template <typename A>
375 void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages,
376     const semantics::Scope &scope, const IntrinsicProcTable &table) {
377   if (auto why{CheckSpecificationExprHelper{scope, table}(x)}) {
378     messages.Say("Invalid specification expression: %s"_err_en_US, *why);
379   }
380 }
381 
382 template void CheckSpecificationExpr(const Expr<SomeType> &,
383     parser::ContextualMessages &, const semantics::Scope &,
384     const IntrinsicProcTable &);
385 template void CheckSpecificationExpr(const Expr<SomeInteger> &,
386     parser::ContextualMessages &, const semantics::Scope &,
387     const IntrinsicProcTable &);
388 template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
389     parser::ContextualMessages &, const semantics::Scope &,
390     const IntrinsicProcTable &);
391 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
392     parser::ContextualMessages &, const semantics::Scope &,
393     const IntrinsicProcTable &);
394 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
395     parser::ContextualMessages &, const semantics::Scope &,
396     const IntrinsicProcTable &);
397 template void CheckSpecificationExpr(
398     const std::optional<Expr<SubscriptInteger>> &, parser::ContextualMessages &,
399     const semantics::Scope &, const IntrinsicProcTable &);
400 
401 // IsSimplyContiguous() -- 9.5.4
402 class IsSimplyContiguousHelper
403     : public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> {
404 public:
405   using Result = std::optional<bool>; // tri-state
406   using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
407   explicit IsSimplyContiguousHelper(const IntrinsicProcTable &t)
408       : Base{*this}, table_{t} {}
409   using Base::operator();
410 
411   Result operator()(const semantics::Symbol &symbol) const {
412     if (symbol.attrs().test(semantics::Attr::CONTIGUOUS) ||
413         symbol.Rank() == 0) {
414       return true;
415     } else if (semantics::IsPointer(symbol)) {
416       return false;
417     } else if (const auto *details{
418                    symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
419       // N.B. ALLOCATABLEs are deferred shape, not assumed, and
420       // are obviously contiguous.
421       return !details->IsAssumedShape() && !details->IsAssumedRank();
422     } else {
423       return false;
424     }
425   }
426 
427   Result operator()(const ArrayRef &x) const {
428     const auto &symbol{x.GetLastSymbol()};
429     if (!(*this)(symbol)) {
430       return false;
431     } else if (auto rank{CheckSubscripts(x.subscript())}) {
432       // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is
433       return *rank > 0 || x.Rank() == 0;
434     } else {
435       return false;
436     }
437   }
438   Result operator()(const CoarrayRef &x) const {
439     return CheckSubscripts(x.subscript()).has_value();
440   }
441   Result operator()(const Component &x) const {
442     return x.base().Rank() == 0 && (*this)(x.GetLastSymbol());
443   }
444   Result operator()(const ComplexPart &) const { return false; }
445   Result operator()(const Substring &) const { return false; }
446 
447   template <typename T> Result operator()(const FunctionRef<T> &x) const {
448     if (auto chars{
449             characteristics::Procedure::Characterize(x.proc(), table_)}) {
450       if (chars->functionResult) {
451         const auto &result{*chars->functionResult};
452         return !result.IsProcedurePointer() &&
453             result.attrs.test(characteristics::FunctionResult::Attr::Pointer) &&
454             result.attrs.test(
455                 characteristics::FunctionResult::Attr::Contiguous);
456       }
457     }
458     return false;
459   }
460 
461 private:
462   // If the subscripts can possibly be on a simply-contiguous array reference,
463   // return the rank.
464   static std::optional<int> CheckSubscripts(
465       const std::vector<Subscript> &subscript) {
466     bool anyTriplet{false};
467     int rank{0};
468     for (auto j{subscript.size()}; j-- > 0;) {
469       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
470         if (!triplet->IsStrideOne()) {
471           return std::nullopt;
472         } else if (anyTriplet) {
473           if (triplet->lower() || triplet->upper()) {
474             // all triplets before the last one must be just ":"
475             return std::nullopt;
476           }
477         } else {
478           anyTriplet = true;
479         }
480         ++rank;
481       } else if (anyTriplet || subscript[j].Rank() > 0) {
482         return std::nullopt;
483       }
484     }
485     return rank;
486   }
487 
488   const IntrinsicProcTable &table_;
489 };
490 
491 template <typename A>
492 bool IsSimplyContiguous(const A &x, const IntrinsicProcTable &table) {
493   if (IsVariable(x)) {
494     auto known{IsSimplyContiguousHelper{table}(x)};
495     return known && *known;
496   } else {
497     return true; // not a variable
498   }
499 }
500 
501 template bool IsSimplyContiguous(
502     const Expr<SomeType> &, const IntrinsicProcTable &);
503 
504 } // namespace Fortran::evaluate
505