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