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/characteristics.h"
11 #include "flang/Evaluate/intrinsics.h"
12 #include "flang/Evaluate/traverse.h"
13 #include "flang/Evaluate/type.h"
14 #include "flang/Semantics/symbol.h"
15 #include "flang/Semantics/tools.h"
16 #include <set>
17 #include <string>
18
19 namespace Fortran::evaluate {
20
21 // Constant expression predicate IsConstantExpr().
22 // This code determines whether an expression is a "constant expression"
23 // in the sense of section 10.1.12. This is not the same thing as being
24 // able to fold it (yet) into a known constant value; specifically,
25 // the expression may reference derived type kind parameters whose values
26 // are not yet known.
27 class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
28 public:
29 using Base = AllTraverse<IsConstantExprHelper, true>;
IsConstantExprHelper()30 IsConstantExprHelper() : Base{*this} {}
31 using Base::operator();
32
operator ()(const TypeParamInquiry & inq) const33 bool operator()(const TypeParamInquiry &inq) const {
34 return semantics::IsKindTypeParameter(inq.parameter());
35 }
operator ()(const semantics::Symbol & symbol) const36 bool operator()(const semantics::Symbol &symbol) const {
37 const auto &ultimate{symbol.GetUltimate()};
38 return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
39 IsInitialProcedureTarget(ultimate);
40 }
operator ()(const CoarrayRef &) const41 bool operator()(const CoarrayRef &) const { return false; }
operator ()(const semantics::ParamValue & param) const42 bool operator()(const semantics::ParamValue ¶m) const {
43 return param.isExplicit() && (*this)(param.GetExplicit());
44 }
operator ()(const FunctionRef<T> & call) const45 template <typename T> bool operator()(const FunctionRef<T> &call) const {
46 if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
47 // kind is always a constant, and we avoid cascading errors by calling
48 // invalid calls to intrinsics constant
49 return intrinsic->name == "kind" ||
50 intrinsic->name == IntrinsicProcTable::InvalidName;
51 // TODO: other inquiry intrinsics
52 } else {
53 return false;
54 }
55 }
operator ()(const StructureConstructor & constructor) const56 bool operator()(const StructureConstructor &constructor) const {
57 for (const auto &[symRef, expr] : constructor) {
58 if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
59 return false;
60 }
61 }
62 return true;
63 }
operator ()(const Component & component) const64 bool operator()(const Component &component) const {
65 return (*this)(component.base());
66 }
67 // Forbid integer division by zero in constants.
68 template <int KIND>
operator ()(const Divide<Type<TypeCategory::Integer,KIND>> & division) const69 bool operator()(
70 const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
71 using T = Type<TypeCategory::Integer, KIND>;
72 if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
73 return !divisor->IsZero() && (*this)(division.left());
74 } else {
75 return false;
76 }
77 }
78
operator ()(const Constant<SomeDerived> &) const79 bool operator()(const Constant<SomeDerived> &) const { return true; }
80
81 private:
IsConstantStructureConstructorComponent(const Symbol & component,const Expr<SomeType> & expr) const82 bool IsConstantStructureConstructorComponent(
83 const Symbol &component, const Expr<SomeType> &expr) const {
84 if (IsAllocatable(component)) {
85 return IsNullPointer(expr);
86 } else if (IsPointer(component)) {
87 return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
88 IsInitialProcedureTarget(expr);
89 } else {
90 return (*this)(expr);
91 }
92 }
93 };
94
IsConstantExpr(const A & x)95 template <typename A> bool IsConstantExpr(const A &x) {
96 return IsConstantExprHelper{}(x);
97 }
98 template bool IsConstantExpr(const Expr<SomeType> &);
99 template bool IsConstantExpr(const Expr<SomeInteger> &);
100 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
101 template bool IsConstantExpr(const StructureConstructor &);
102
103 // IsActuallyConstant()
104 struct IsActuallyConstantHelper {
operator ()Fortran::evaluate::IsActuallyConstantHelper105 template <typename A> bool operator()(const A &) { return false; }
operator ()Fortran::evaluate::IsActuallyConstantHelper106 template <typename T> bool operator()(const Constant<T> &) { return true; }
operator ()Fortran::evaluate::IsActuallyConstantHelper107 template <typename T> bool operator()(const Parentheses<T> &x) {
108 return (*this)(x.left());
109 }
operator ()Fortran::evaluate::IsActuallyConstantHelper110 template <typename T> bool operator()(const Expr<T> &x) {
111 return std::visit([=](const auto &y) { return (*this)(y); }, x.u);
112 }
operator ()Fortran::evaluate::IsActuallyConstantHelper113 template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
operator ()Fortran::evaluate::IsActuallyConstantHelper114 template <typename A> bool operator()(const std::optional<A> &x) {
115 return x && (*this)(*x);
116 }
117 };
118
IsActuallyConstant(const A & x)119 template <typename A> bool IsActuallyConstant(const A &x) {
120 return IsActuallyConstantHelper{}(x);
121 }
122
123 template bool IsActuallyConstant(const Expr<SomeType> &);
124
125 // Object pointer initialization checking predicate IsInitialDataTarget().
126 // This code determines whether an expression is allowable as the static
127 // data address used to initialize a pointer with "=> x". See C765.
128 class IsInitialDataTargetHelper
129 : public AllTraverse<IsInitialDataTargetHelper, true> {
130 public:
131 using Base = AllTraverse<IsInitialDataTargetHelper, true>;
132 using Base::operator();
IsInitialDataTargetHelper(parser::ContextualMessages * m)133 explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
134 : Base{*this}, messages_{m} {}
135
emittedMessage() const136 bool emittedMessage() const { return emittedMessage_; }
137
operator ()(const BOZLiteralConstant &) const138 bool operator()(const BOZLiteralConstant &) const { return false; }
operator ()(const NullPointer &) const139 bool operator()(const NullPointer &) const { return true; }
operator ()(const Constant<T> &) const140 template <typename T> bool operator()(const Constant<T> &) const {
141 return false;
142 }
operator ()(const semantics::Symbol & symbol)143 bool operator()(const semantics::Symbol &symbol) {
144 const Symbol &ultimate{symbol.GetUltimate()};
145 if (IsAllocatable(ultimate)) {
146 if (messages_) {
147 messages_->Say(
148 "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
149 ultimate.name());
150 emittedMessage_ = true;
151 }
152 return false;
153 } else if (ultimate.Corank() > 0) {
154 if (messages_) {
155 messages_->Say(
156 "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
157 ultimate.name());
158 emittedMessage_ = true;
159 }
160 return false;
161 } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
162 if (messages_) {
163 messages_->Say(
164 "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
165 ultimate.name());
166 emittedMessage_ = true;
167 }
168 return false;
169 } else if (!IsSaved(ultimate)) {
170 if (messages_) {
171 messages_->Say(
172 "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
173 ultimate.name());
174 emittedMessage_ = true;
175 }
176 return false;
177 }
178 return true;
179 }
operator ()(const StaticDataObject &) const180 bool operator()(const StaticDataObject &) const { return false; }
operator ()(const TypeParamInquiry &) const181 bool operator()(const TypeParamInquiry &) const { return false; }
operator ()(const Triplet & x) const182 bool operator()(const Triplet &x) const {
183 return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
184 IsConstantExpr(x.stride());
185 }
operator ()(const Subscript & x) const186 bool operator()(const Subscript &x) const {
187 return std::visit(common::visitors{
188 [&](const Triplet &t) { return (*this)(t); },
189 [&](const auto &y) {
190 return y.value().Rank() == 0 &&
191 IsConstantExpr(y.value());
192 },
193 },
194 x.u);
195 }
operator ()(const CoarrayRef &) const196 bool operator()(const CoarrayRef &) const { return false; }
operator ()(const Substring & x) const197 bool operator()(const Substring &x) const {
198 return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
199 (*this)(x.parent());
200 }
operator ()(const DescriptorInquiry &) const201 bool operator()(const DescriptorInquiry &) const { return false; }
operator ()(const ArrayConstructor<T> &) const202 template <typename T> bool operator()(const ArrayConstructor<T> &) const {
203 return false;
204 }
operator ()(const StructureConstructor &) const205 bool operator()(const StructureConstructor &) const { return false; }
operator ()(const FunctionRef<T> &)206 template <typename T> bool operator()(const FunctionRef<T> &) {
207 return false;
208 }
209 template <typename D, typename R, typename... O>
operator ()(const Operation<D,R,O...> &) const210 bool operator()(const Operation<D, R, O...> &) const {
211 return false;
212 }
operator ()(const Parentheses<T> & x) const213 template <typename T> bool operator()(const Parentheses<T> &x) const {
214 return (*this)(x.left());
215 }
operator ()(const FunctionRef<T> & x) const216 template <typename T> bool operator()(const FunctionRef<T> &x) const {
217 return false;
218 }
operator ()(const Relational<SomeType> &) const219 bool operator()(const Relational<SomeType> &) const { return false; }
220
221 private:
222 parser::ContextualMessages *messages_;
223 bool emittedMessage_{false};
224 };
225
IsInitialDataTarget(const Expr<SomeType> & x,parser::ContextualMessages * messages)226 bool IsInitialDataTarget(
227 const Expr<SomeType> &x, parser::ContextualMessages *messages) {
228 IsInitialDataTargetHelper helper{messages};
229 bool result{helper(x)};
230 if (!result && messages && !helper.emittedMessage()) {
231 messages->Say(
232 "An initial data target must be a designator with constant subscripts"_err_en_US);
233 }
234 return result;
235 }
236
IsInitialProcedureTarget(const semantics::Symbol & symbol)237 bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
238 const auto &ultimate{symbol.GetUltimate()};
239 return std::visit(
240 common::visitors{
241 [](const semantics::SubprogramDetails &) { return true; },
242 [](const semantics::SubprogramNameDetails &) { return true; },
243 [&](const semantics::ProcEntityDetails &proc) {
244 return !semantics::IsPointer(ultimate) && !proc.isDummy();
245 },
246 [](const auto &) { return false; },
247 },
248 ultimate.details());
249 }
250
IsInitialProcedureTarget(const ProcedureDesignator & proc)251 bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
252 if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
253 return !intrin->isRestrictedSpecific;
254 } else if (proc.GetComponent()) {
255 return false;
256 } else {
257 return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
258 }
259 }
260
IsInitialProcedureTarget(const Expr<SomeType> & expr)261 bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
262 if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
263 return IsInitialProcedureTarget(*proc);
264 } else {
265 return IsNullPointer(expr);
266 }
267 }
268
269 class ScalarExpansionVisitor : public AnyTraverse<ScalarExpansionVisitor,
270 std::optional<Expr<SomeType>>> {
271 public:
272 using Result = std::optional<Expr<SomeType>>;
273 using Base = AnyTraverse<ScalarExpansionVisitor, Result>;
ScalarExpansionVisitor(ConstantSubscripts && shape,std::optional<ConstantSubscripts> && lb)274 ScalarExpansionVisitor(
275 ConstantSubscripts &&shape, std::optional<ConstantSubscripts> &&lb)
276 : Base{*this}, shape_{std::move(shape)}, lbounds_{std::move(lb)} {}
277 using Base::operator();
operator ()(const Constant<T> & x)278 template <typename T> Result operator()(const Constant<T> &x) {
279 auto expanded{x.Reshape(std::move(shape_))};
280 if (lbounds_) {
281 expanded.set_lbounds(std::move(*lbounds_));
282 }
283 return AsGenericExpr(std::move(expanded));
284 }
285
286 private:
287 ConstantSubscripts shape_;
288 std::optional<ConstantSubscripts> lbounds_;
289 };
290
291 // Converts, folds, and then checks type, rank, and shape of an
292 // initialization expression for a named constant, a non-pointer
293 // variable static initializatio, a component default initializer,
294 // a type parameter default value, or instantiated type parameter value.
NonPointerInitializationExpr(const Symbol & symbol,Expr<SomeType> && x,FoldingContext & context,const semantics::Scope * instantiation)295 std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
296 Expr<SomeType> &&x, FoldingContext &context,
297 const semantics::Scope *instantiation) {
298 CHECK(!IsPointer(symbol));
299 if (auto symTS{
300 characteristics::TypeAndShape::Characterize(symbol, context)}) {
301 auto xType{x.GetType()};
302 if (auto converted{ConvertToType(symTS->type(), std::move(x))}) {
303 auto folded{Fold(context, std::move(*converted))};
304 if (IsActuallyConstant(folded)) {
305 int symRank{GetRank(symTS->shape())};
306 if (IsImpliedShape(symbol)) {
307 if (folded.Rank() == symRank) {
308 return {std::move(folded)};
309 } else {
310 context.messages().Say(
311 "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
312 symbol.name(), symRank, folded.Rank());
313 }
314 } else if (auto extents{AsConstantExtents(context, symTS->shape())}) {
315 if (folded.Rank() == 0 && symRank > 0) {
316 return ScalarConstantExpander{std::move(*extents),
317 AsConstantExtents(
318 context, GetLowerBounds(context, NamedEntity{symbol}))}
319 .Expand(std::move(folded));
320 } else if (auto resultShape{GetShape(context, folded)}) {
321 if (CheckConformance(context.messages(), symTS->shape(),
322 *resultShape, "initialized object",
323 "initialization expression", false, false)) {
324 return {std::move(folded)};
325 }
326 }
327 } else if (IsNamedConstant(symbol)) {
328 if (IsExplicitShape(symbol)) {
329 context.messages().Say(
330 "Named constant '%s' array must have constant shape"_err_en_US,
331 symbol.name());
332 } else {
333 // Declaration checking handles other cases
334 }
335 } else {
336 context.messages().Say(
337 "Shape of initialized object '%s' must be constant"_err_en_US,
338 symbol.name());
339 }
340 } else if (IsErrorExpr(folded)) {
341 } else if (IsLenTypeParameter(symbol)) {
342 return {std::move(folded)};
343 } else if (IsKindTypeParameter(symbol)) {
344 if (instantiation) {
345 context.messages().Say(
346 "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,
347 symbol.name(), folded.AsFortran());
348 } else {
349 return {std::move(folded)};
350 }
351 } else if (IsNamedConstant(symbol)) {
352 context.messages().Say(
353 "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,
354 symbol.name(), folded.AsFortran());
355 } else {
356 context.messages().Say(
357 "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,
358 symbol.name(), folded.AsFortran());
359 }
360 } else if (xType) {
361 context.messages().Say(
362 "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,
363 symbol.name(), xType->AsFortran());
364 } else {
365 context.messages().Say(
366 "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
367 symbol.name());
368 }
369 }
370 return std::nullopt;
371 }
372
373 // Specification expression validation (10.1.11(2), C1010)
374 class CheckSpecificationExprHelper
375 : public AnyTraverse<CheckSpecificationExprHelper,
376 std::optional<std::string>> {
377 public:
378 using Result = std::optional<std::string>;
379 using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
CheckSpecificationExprHelper(const semantics::Scope & s,FoldingContext & context)380 explicit CheckSpecificationExprHelper(
381 const semantics::Scope &s, FoldingContext &context)
382 : Base{*this}, scope_{s}, context_{context} {}
383 using Base::operator();
384
operator ()(const ProcedureDesignator &) const385 Result operator()(const ProcedureDesignator &) const {
386 return "dummy procedure argument";
387 }
operator ()(const CoarrayRef &) const388 Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
389
operator ()(const semantics::Symbol & symbol) const390 Result operator()(const semantics::Symbol &symbol) const {
391 const auto &ultimate{symbol.GetUltimate()};
392 if (semantics::IsNamedConstant(ultimate) || ultimate.owner().IsModule() ||
393 ultimate.owner().IsSubmodule()) {
394 return std::nullopt;
395 } else if (scope_.IsDerivedType() &&
396 IsVariableName(ultimate)) { // C750, C754
397 return "derived type component or type parameter value not allowed to "
398 "reference variable '"s +
399 ultimate.name().ToString() + "'";
400 } else if (IsDummy(ultimate)) {
401 if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
402 return "reference to OPTIONAL dummy argument '"s +
403 ultimate.name().ToString() + "'";
404 } else if (ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
405 return "reference to INTENT(OUT) dummy argument '"s +
406 ultimate.name().ToString() + "'";
407 } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
408 return std::nullopt;
409 } else {
410 return "dummy procedure argument";
411 }
412 } else if (const auto *object{
413 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
414 // TODO: what about EQUIVALENCE with data in COMMON?
415 // TODO: does this work for blank COMMON?
416 if (object->commonBlock()) {
417 return std::nullopt;
418 }
419 }
420 for (const semantics::Scope *s{&scope_}; !s->IsGlobal();) {
421 s = &s->parent();
422 if (s == &ultimate.owner()) {
423 return std::nullopt;
424 }
425 }
426 return "reference to local entity '"s + ultimate.name().ToString() + "'";
427 }
428
operator ()(const Component & x) const429 Result operator()(const Component &x) const {
430 // Don't look at the component symbol.
431 return (*this)(x.base());
432 }
operator ()(const DescriptorInquiry &) const433 Result operator()(const DescriptorInquiry &) const {
434 // Subtle: Uses of SIZE(), LBOUND(), &c. that are valid in specification
435 // expressions will have been converted to expressions over descriptor
436 // inquiries by Fold().
437 return std::nullopt;
438 }
439
operator ()(const TypeParamInquiry & inq) const440 Result operator()(const TypeParamInquiry &inq) const {
441 if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
442 inq.base() /* X%T, not local T */) { // C750, C754
443 return "non-constant reference to a type parameter inquiry not "
444 "allowed for derived type components or type parameter values";
445 }
446 return std::nullopt;
447 }
448
operator ()(const FunctionRef<T> & x) const449 template <typename T> Result operator()(const FunctionRef<T> &x) const {
450 if (const auto *symbol{x.proc().GetSymbol()}) {
451 if (!semantics::IsPureProcedure(*symbol)) {
452 return "reference to impure function '"s + symbol->name().ToString() +
453 "'";
454 }
455 if (semantics::IsStmtFunction(*symbol)) {
456 return "reference to statement function '"s +
457 symbol->name().ToString() + "'";
458 }
459 if (scope_.IsDerivedType()) { // C750, C754
460 return "reference to function '"s + symbol->name().ToString() +
461 "' not allowed for derived type components or type parameter"
462 " values";
463 }
464 // TODO: other checks for standard module procedures
465 } else {
466 const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
467 if (scope_.IsDerivedType()) { // C750, C754
468 if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
469 badIntrinsicsForComponents_.find(intrin.name) !=
470 badIntrinsicsForComponents_.end()) ||
471 IsProhibitedFunction(intrin.name)) {
472 return "reference to intrinsic '"s + intrin.name +
473 "' not allowed for derived type components or type parameter"
474 " values";
475 }
476 if (context_.intrinsics().GetIntrinsicClass(intrin.name) ==
477 IntrinsicClass::inquiryFunction &&
478 !IsConstantExpr(x)) {
479 return "non-constant reference to inquiry intrinsic '"s +
480 intrin.name +
481 "' not allowed for derived type components or type"
482 " parameter values";
483 }
484 } else if (intrin.name == "present") {
485 return std::nullopt; // no need to check argument(s)
486 }
487 if (IsConstantExpr(x)) {
488 // inquiry functions may not need to check argument(s)
489 return std::nullopt;
490 }
491 }
492 return (*this)(x.arguments());
493 }
494
495 private:
496 const semantics::Scope &scope_;
497 FoldingContext &context_;
498 const std::set<std::string> badIntrinsicsForComponents_{
499 "allocated", "associated", "extends_type_of", "present", "same_type_as"};
IsProhibitedFunction(std::string name)500 static bool IsProhibitedFunction(std::string name) { return false; }
501 };
502
503 template <typename A>
CheckSpecificationExpr(const A & x,const semantics::Scope & scope,FoldingContext & context)504 void CheckSpecificationExpr(
505 const A &x, const semantics::Scope &scope, FoldingContext &context) {
506 if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) {
507 context.messages().Say(
508 "Invalid specification expression: %s"_err_en_US, *why);
509 }
510 }
511
512 template void CheckSpecificationExpr(
513 const Expr<SomeType> &, const semantics::Scope &, FoldingContext &);
514 template void CheckSpecificationExpr(
515 const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &);
516 template void CheckSpecificationExpr(
517 const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &);
518 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
519 const semantics::Scope &, FoldingContext &);
520 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
521 const semantics::Scope &, FoldingContext &);
522 template void CheckSpecificationExpr(
523 const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
524 FoldingContext &);
525
526 // IsSimplyContiguous() -- 9.5.4
527 class IsSimplyContiguousHelper
528 : public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> {
529 public:
530 using Result = std::optional<bool>; // tri-state
531 using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
IsSimplyContiguousHelper(FoldingContext & c)532 explicit IsSimplyContiguousHelper(FoldingContext &c)
533 : Base{*this}, context_{c} {}
534 using Base::operator();
535
operator ()(const semantics::Symbol & symbol) const536 Result operator()(const semantics::Symbol &symbol) const {
537 if (symbol.attrs().test(semantics::Attr::CONTIGUOUS) ||
538 symbol.Rank() == 0) {
539 return true;
540 } else if (semantics::IsPointer(symbol)) {
541 return false;
542 } else if (const auto *details{
543 symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
544 // N.B. ALLOCATABLEs are deferred shape, not assumed, and
545 // are obviously contiguous.
546 return !details->IsAssumedShape() && !details->IsAssumedRank();
547 } else {
548 return false;
549 }
550 }
551
operator ()(const ArrayRef & x) const552 Result operator()(const ArrayRef &x) const {
553 const auto &symbol{x.GetLastSymbol()};
554 if (!(*this)(symbol)) {
555 return false;
556 } else if (auto rank{CheckSubscripts(x.subscript())}) {
557 // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is
558 return *rank > 0 || x.Rank() == 0;
559 } else {
560 return false;
561 }
562 }
operator ()(const CoarrayRef & x) const563 Result operator()(const CoarrayRef &x) const {
564 return CheckSubscripts(x.subscript()).has_value();
565 }
operator ()(const Component & x) const566 Result operator()(const Component &x) const {
567 return x.base().Rank() == 0 && (*this)(x.GetLastSymbol());
568 }
operator ()(const ComplexPart &) const569 Result operator()(const ComplexPart &) const { return false; }
operator ()(const Substring &) const570 Result operator()(const Substring &) const { return false; }
571
operator ()(const FunctionRef<T> & x) const572 template <typename T> Result operator()(const FunctionRef<T> &x) const {
573 if (auto chars{
574 characteristics::Procedure::Characterize(x.proc(), context_)}) {
575 if (chars->functionResult) {
576 const auto &result{*chars->functionResult};
577 return !result.IsProcedurePointer() &&
578 result.attrs.test(characteristics::FunctionResult::Attr::Pointer) &&
579 result.attrs.test(
580 characteristics::FunctionResult::Attr::Contiguous);
581 }
582 }
583 return false;
584 }
585
586 private:
587 // If the subscripts can possibly be on a simply-contiguous array reference,
588 // return the rank.
CheckSubscripts(const std::vector<Subscript> & subscript)589 static std::optional<int> CheckSubscripts(
590 const std::vector<Subscript> &subscript) {
591 bool anyTriplet{false};
592 int rank{0};
593 for (auto j{subscript.size()}; j-- > 0;) {
594 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
595 if (!triplet->IsStrideOne()) {
596 return std::nullopt;
597 } else if (anyTriplet) {
598 if (triplet->lower() || triplet->upper()) {
599 // all triplets before the last one must be just ":"
600 return std::nullopt;
601 }
602 } else {
603 anyTriplet = true;
604 }
605 ++rank;
606 } else if (anyTriplet || subscript[j].Rank() > 0) {
607 return std::nullopt;
608 }
609 }
610 return rank;
611 }
612
613 FoldingContext &context_;
614 };
615
616 template <typename A>
IsSimplyContiguous(const A & x,FoldingContext & context)617 bool IsSimplyContiguous(const A &x, FoldingContext &context) {
618 if (IsVariable(x)) {
619 auto known{IsSimplyContiguousHelper{context}(x)};
620 return known && *known;
621 } else {
622 return true; // not a variable
623 }
624 }
625
626 template bool IsSimplyContiguous(const Expr<SomeType> &, FoldingContext &);
627
628 // IsErrorExpr()
629 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
630 using Result = bool;
631 using Base = AnyTraverse<IsErrorExprHelper, Result>;
IsErrorExprHelperFortran::evaluate::IsErrorExprHelper632 IsErrorExprHelper() : Base{*this} {}
633 using Base::operator();
634
operator ()Fortran::evaluate::IsErrorExprHelper635 bool operator()(const SpecificIntrinsic &x) {
636 return x.name == IntrinsicProcTable::InvalidName;
637 }
638 };
639
IsErrorExpr(const A & x)640 template <typename A> bool IsErrorExpr(const A &x) {
641 return IsErrorExprHelper{}(x);
642 }
643
644 template bool IsErrorExpr(const Expr<SomeType> &);
645
646 } // namespace Fortran::evaluate
647