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>; 30 IsConstantExprHelper() : Base{*this} {} 31 using Base::operator(); 32 33 // A missing expression is not considered to be constant. 34 template <typename A> bool operator()(const std::optional<A> &x) const { 35 return x && (*this)(*x); 36 } 37 38 bool operator()(const TypeParamInquiry &inq) const { 39 return semantics::IsKindTypeParameter(inq.parameter()); 40 } 41 bool operator()(const semantics::Symbol &symbol) const { 42 const auto &ultimate{GetAssociationRoot(symbol)}; 43 return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) || 44 IsInitialProcedureTarget(ultimate); 45 } 46 bool operator()(const CoarrayRef &) const { return false; } 47 bool operator()(const semantics::ParamValue ¶m) const { 48 return param.isExplicit() && (*this)(param.GetExplicit()); 49 } 50 bool operator()(const ProcedureRef &) const; 51 bool operator()(const StructureConstructor &constructor) const { 52 for (const auto &[symRef, expr] : constructor) { 53 if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) { 54 return false; 55 } 56 } 57 return true; 58 } 59 bool operator()(const Component &component) const { 60 return (*this)(component.base()); 61 } 62 // Forbid integer division by zero in constants. 63 template <int KIND> 64 bool operator()( 65 const Divide<Type<TypeCategory::Integer, KIND>> &division) const { 66 using T = Type<TypeCategory::Integer, KIND>; 67 if (const auto divisor{GetScalarConstantValue<T>(division.right())}) { 68 return !divisor->IsZero() && (*this)(division.left()); 69 } else { 70 return false; 71 } 72 } 73 74 bool operator()(const Constant<SomeDerived> &) const { return true; } 75 bool operator()(const DescriptorInquiry &) const { return false; } 76 77 private: 78 bool IsConstantStructureConstructorComponent( 79 const Symbol &, const Expr<SomeType> &) const; 80 bool IsConstantExprShape(const Shape &) const; 81 }; 82 83 bool IsConstantExprHelper::IsConstantStructureConstructorComponent( 84 const Symbol &component, const Expr<SomeType> &expr) const { 85 if (IsAllocatable(component)) { 86 return IsNullPointer(expr); 87 } else if (IsPointer(component)) { 88 return IsNullPointer(expr) || IsInitialDataTarget(expr) || 89 IsInitialProcedureTarget(expr); 90 } else { 91 return (*this)(expr); 92 } 93 } 94 95 bool IsConstantExprHelper::operator()(const ProcedureRef &call) const { 96 // LBOUND, UBOUND, and SIZE with DIM= arguments will have been reritten 97 // into DescriptorInquiry operations. 98 if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) { 99 if (intrinsic->name == "kind" || 100 intrinsic->name == IntrinsicProcTable::InvalidName) { 101 // kind is always a constant, and we avoid cascading errors by considering 102 // invalid calls to intrinsics to be constant 103 return true; 104 } else if (intrinsic->name == "lbound" && call.arguments().size() == 1) { 105 // LBOUND(x) without DIM= 106 auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())}; 107 return base && IsConstantExprShape(GetLowerBounds(*base)); 108 } else if (intrinsic->name == "ubound" && call.arguments().size() == 1) { 109 // UBOUND(x) without DIM= 110 auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())}; 111 return base && IsConstantExprShape(GetUpperBounds(*base)); 112 } else if (intrinsic->name == "shape") { 113 auto shape{GetShape(call.arguments()[0]->UnwrapExpr())}; 114 return shape && IsConstantExprShape(*shape); 115 } else if (intrinsic->name == "size" && call.arguments().size() == 1) { 116 // SIZE(x) without DIM 117 auto shape{GetShape(call.arguments()[0]->UnwrapExpr())}; 118 return shape && IsConstantExprShape(*shape); 119 } 120 // TODO: STORAGE_SIZE 121 } 122 return false; 123 } 124 125 bool IsConstantExprHelper::IsConstantExprShape(const Shape &shape) const { 126 for (const auto &extent : shape) { 127 if (!(*this)(extent)) { 128 return false; 129 } 130 } 131 return true; 132 } 133 134 template <typename A> bool IsConstantExpr(const A &x) { 135 return IsConstantExprHelper{}(x); 136 } 137 template bool IsConstantExpr(const Expr<SomeType> &); 138 template bool IsConstantExpr(const Expr<SomeInteger> &); 139 template bool IsConstantExpr(const Expr<SubscriptInteger> &); 140 template bool IsConstantExpr(const StructureConstructor &); 141 142 // IsActuallyConstant() 143 struct IsActuallyConstantHelper { 144 template <typename A> bool operator()(const A &) { return false; } 145 template <typename T> bool operator()(const Constant<T> &) { return true; } 146 template <typename T> bool operator()(const Parentheses<T> &x) { 147 return (*this)(x.left()); 148 } 149 template <typename T> bool operator()(const Expr<T> &x) { 150 return std::visit([=](const auto &y) { return (*this)(y); }, x.u); 151 } 152 template <typename A> bool operator()(const A *x) { return x && (*this)(*x); } 153 template <typename A> bool operator()(const std::optional<A> &x) { 154 return x && (*this)(*x); 155 } 156 }; 157 158 template <typename A> bool IsActuallyConstant(const A &x) { 159 return IsActuallyConstantHelper{}(x); 160 } 161 162 template bool IsActuallyConstant(const Expr<SomeType> &); 163 164 // Object pointer initialization checking predicate IsInitialDataTarget(). 165 // This code determines whether an expression is allowable as the static 166 // data address used to initialize a pointer with "=> x". See C765. 167 class IsInitialDataTargetHelper 168 : public AllTraverse<IsInitialDataTargetHelper, true> { 169 public: 170 using Base = AllTraverse<IsInitialDataTargetHelper, true>; 171 using Base::operator(); 172 explicit IsInitialDataTargetHelper(parser::ContextualMessages *m) 173 : Base{*this}, messages_{m} {} 174 175 bool emittedMessage() const { return emittedMessage_; } 176 177 bool operator()(const BOZLiteralConstant &) const { return false; } 178 bool operator()(const NullPointer &) const { return true; } 179 template <typename T> bool operator()(const Constant<T> &) const { 180 return false; 181 } 182 bool operator()(const semantics::Symbol &symbol) { 183 // This function checks only base symbols, not components. 184 const Symbol &ultimate{symbol.GetUltimate()}; 185 if (const auto *assoc{ 186 ultimate.detailsIf<semantics::AssocEntityDetails>()}) { 187 if (const auto &expr{assoc->expr()}) { 188 if (IsVariable(*expr)) { 189 return (*this)(*expr); 190 } else if (messages_) { 191 messages_->Say( 192 "An initial data target may not be an associated expression ('%s')"_err_en_US, 193 ultimate.name()); 194 emittedMessage_ = true; 195 } 196 } 197 return false; 198 } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) { 199 if (messages_) { 200 messages_->Say( 201 "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US, 202 ultimate.name()); 203 emittedMessage_ = true; 204 } 205 return false; 206 } else if (!IsSaved(ultimate)) { 207 if (messages_) { 208 messages_->Say( 209 "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US, 210 ultimate.name()); 211 emittedMessage_ = true; 212 } 213 return false; 214 } else { 215 return CheckVarOrComponent(ultimate); 216 } 217 } 218 bool operator()(const StaticDataObject &) const { return false; } 219 bool operator()(const TypeParamInquiry &) const { return false; } 220 bool operator()(const Triplet &x) const { 221 return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) && 222 IsConstantExpr(x.stride()); 223 } 224 bool operator()(const Subscript &x) const { 225 return std::visit(common::visitors{ 226 [&](const Triplet &t) { return (*this)(t); }, 227 [&](const auto &y) { 228 return y.value().Rank() == 0 && 229 IsConstantExpr(y.value()); 230 }, 231 }, 232 x.u); 233 } 234 bool operator()(const CoarrayRef &) const { return false; } 235 bool operator()(const Component &x) { 236 return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base()); 237 } 238 bool operator()(const Substring &x) const { 239 return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) && 240 (*this)(x.parent()); 241 } 242 bool operator()(const DescriptorInquiry &) const { return false; } 243 template <typename T> bool operator()(const ArrayConstructor<T> &) const { 244 return false; 245 } 246 bool operator()(const StructureConstructor &) const { return false; } 247 template <typename T> bool operator()(const FunctionRef<T> &) { 248 return false; 249 } 250 template <typename D, typename R, typename... O> 251 bool operator()(const Operation<D, R, O...> &) const { 252 return false; 253 } 254 template <typename T> bool operator()(const Parentheses<T> &x) const { 255 return (*this)(x.left()); 256 } 257 template <typename T> bool operator()(const FunctionRef<T> &x) const { 258 return false; 259 } 260 bool operator()(const Relational<SomeType> &) const { return false; } 261 262 private: 263 bool CheckVarOrComponent(const semantics::Symbol &symbol) { 264 const Symbol &ultimate{symbol.GetUltimate()}; 265 if (IsAllocatable(ultimate)) { 266 if (messages_) { 267 messages_->Say( 268 "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US, 269 ultimate.name()); 270 emittedMessage_ = true; 271 } 272 return false; 273 } else if (ultimate.Corank() > 0) { 274 if (messages_) { 275 messages_->Say( 276 "An initial data target may not be a reference to a coarray '%s'"_err_en_US, 277 ultimate.name()); 278 emittedMessage_ = true; 279 } 280 return false; 281 } 282 return true; 283 } 284 285 parser::ContextualMessages *messages_; 286 bool emittedMessage_{false}; 287 }; 288 289 bool IsInitialDataTarget( 290 const Expr<SomeType> &x, parser::ContextualMessages *messages) { 291 IsInitialDataTargetHelper helper{messages}; 292 bool result{helper(x)}; 293 if (!result && messages && !helper.emittedMessage()) { 294 messages->Say( 295 "An initial data target must be a designator with constant subscripts"_err_en_US); 296 } 297 return result; 298 } 299 300 bool IsInitialProcedureTarget(const semantics::Symbol &symbol) { 301 const auto &ultimate{symbol.GetUltimate()}; 302 return std::visit( 303 common::visitors{ 304 [](const semantics::SubprogramDetails &) { return true; }, 305 [](const semantics::SubprogramNameDetails &) { return true; }, 306 [&](const semantics::ProcEntityDetails &proc) { 307 return !semantics::IsPointer(ultimate) && !proc.isDummy(); 308 }, 309 [](const auto &) { return false; }, 310 }, 311 ultimate.details()); 312 } 313 314 bool IsInitialProcedureTarget(const ProcedureDesignator &proc) { 315 if (const auto *intrin{proc.GetSpecificIntrinsic()}) { 316 return !intrin->isRestrictedSpecific; 317 } else if (proc.GetComponent()) { 318 return false; 319 } else { 320 return IsInitialProcedureTarget(DEREF(proc.GetSymbol())); 321 } 322 } 323 324 bool IsInitialProcedureTarget(const Expr<SomeType> &expr) { 325 if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) { 326 return IsInitialProcedureTarget(*proc); 327 } else { 328 return IsNullPointer(expr); 329 } 330 } 331 332 class ArrayConstantBoundChanger { 333 public: 334 ArrayConstantBoundChanger(ConstantSubscripts &&lbounds) 335 : lbounds_{std::move(lbounds)} {} 336 337 template <typename A> A ChangeLbounds(A &&x) const { 338 return std::move(x); // default case 339 } 340 template <typename T> Constant<T> ChangeLbounds(Constant<T> &&x) { 341 x.set_lbounds(std::move(lbounds_)); 342 return std::move(x); 343 } 344 template <typename T> Expr<T> ChangeLbounds(Parentheses<T> &&x) { 345 return ChangeLbounds( 346 std::move(x.left())); // Constant<> can be parenthesized 347 } 348 template <typename T> Expr<T> ChangeLbounds(Expr<T> &&x) { 349 return std::visit( 350 [&](auto &&x) { return Expr<T>{ChangeLbounds(std::move(x))}; }, 351 std::move(x.u)); // recurse until we hit a constant 352 } 353 354 private: 355 ConstantSubscripts &&lbounds_; 356 }; 357 358 // Converts, folds, and then checks type, rank, and shape of an 359 // initialization expression for a named constant, a non-pointer 360 // variable static initializatio, a component default initializer, 361 // a type parameter default value, or instantiated type parameter value. 362 std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol, 363 Expr<SomeType> &&x, FoldingContext &context, 364 const semantics::Scope *instantiation) { 365 CHECK(!IsPointer(symbol)); 366 if (auto symTS{ 367 characteristics::TypeAndShape::Characterize(symbol, context)}) { 368 auto xType{x.GetType()}; 369 if (auto converted{ConvertToType(symTS->type(), std::move(x))}) { 370 auto folded{Fold(context, std::move(*converted))}; 371 if (IsActuallyConstant(folded)) { 372 int symRank{GetRank(symTS->shape())}; 373 if (IsImpliedShape(symbol)) { 374 if (folded.Rank() == symRank) { 375 return {std::move(folded)}; 376 } else { 377 context.messages().Say( 378 "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US, 379 symbol.name(), symRank, folded.Rank()); 380 } 381 } else if (auto extents{AsConstantExtents(context, symTS->shape())}) { 382 if (folded.Rank() == 0 && symRank == 0) { 383 // symbol and constant are both scalars 384 return {std::move(folded)}; 385 } else if (folded.Rank() == 0 && symRank > 0) { 386 // expand the scalar constant to an array 387 return ScalarConstantExpander{std::move(*extents), 388 AsConstantExtents( 389 context, GetLowerBounds(context, NamedEntity{symbol}))} 390 .Expand(std::move(folded)); 391 } else if (auto resultShape{GetShape(context, folded)}) { 392 if (CheckConformance(context.messages(), symTS->shape(), 393 *resultShape, CheckConformanceFlags::None, 394 "initialized object", "initialization expression") 395 .value_or(false /*fail if not known now to conform*/)) { 396 // make a constant array with adjusted lower bounds 397 return ArrayConstantBoundChanger{ 398 std::move(*AsConstantExtents( 399 context, GetLowerBounds(context, NamedEntity{symbol})))} 400 .ChangeLbounds(std::move(folded)); 401 } 402 } 403 } else if (IsNamedConstant(symbol)) { 404 if (IsExplicitShape(symbol)) { 405 context.messages().Say( 406 "Named constant '%s' array must have constant shape"_err_en_US, 407 symbol.name()); 408 } else { 409 // Declaration checking handles other cases 410 } 411 } else { 412 context.messages().Say( 413 "Shape of initialized object '%s' must be constant"_err_en_US, 414 symbol.name()); 415 } 416 } else if (IsErrorExpr(folded)) { 417 } else if (IsLenTypeParameter(symbol)) { 418 return {std::move(folded)}; 419 } else if (IsKindTypeParameter(symbol)) { 420 if (instantiation) { 421 context.messages().Say( 422 "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US, 423 symbol.name(), folded.AsFortran()); 424 } else { 425 return {std::move(folded)}; 426 } 427 } else if (IsNamedConstant(symbol)) { 428 context.messages().Say( 429 "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US, 430 symbol.name(), folded.AsFortran()); 431 } else { 432 context.messages().Say( 433 "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US, 434 symbol.name(), folded.AsFortran()); 435 } 436 } else if (xType) { 437 context.messages().Say( 438 "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US, 439 symbol.name(), xType->AsFortran()); 440 } else { 441 context.messages().Say( 442 "Initialization expression cannot be converted to declared type of '%s'"_err_en_US, 443 symbol.name()); 444 } 445 } 446 return std::nullopt; 447 } 448 449 // Specification expression validation (10.1.11(2), C1010) 450 class CheckSpecificationExprHelper 451 : public AnyTraverse<CheckSpecificationExprHelper, 452 std::optional<std::string>> { 453 public: 454 using Result = std::optional<std::string>; 455 using Base = AnyTraverse<CheckSpecificationExprHelper, Result>; 456 explicit CheckSpecificationExprHelper( 457 const semantics::Scope &s, FoldingContext &context) 458 : Base{*this}, scope_{s}, context_{context} {} 459 using Base::operator(); 460 461 Result operator()(const ProcedureDesignator &) const { 462 return "dummy procedure argument"; 463 } 464 Result operator()(const CoarrayRef &) const { return "coindexed reference"; } 465 466 Result operator()(const semantics::Symbol &symbol) const { 467 const auto &ultimate{symbol.GetUltimate()}; 468 if (const auto *assoc{ 469 ultimate.detailsIf<semantics::AssocEntityDetails>()}) { 470 return (*this)(assoc->expr()); 471 } else if (semantics::IsNamedConstant(ultimate) || 472 ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) { 473 return std::nullopt; 474 } else if (scope_.IsDerivedType() && 475 IsVariableName(ultimate)) { // C750, C754 476 return "derived type component or type parameter value not allowed to " 477 "reference variable '"s + 478 ultimate.name().ToString() + "'"; 479 } else if (IsDummy(ultimate)) { 480 if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) { 481 return "reference to OPTIONAL dummy argument '"s + 482 ultimate.name().ToString() + "'"; 483 } else if (ultimate.attrs().test(semantics::Attr::INTENT_OUT)) { 484 return "reference to INTENT(OUT) dummy argument '"s + 485 ultimate.name().ToString() + "'"; 486 } else if (ultimate.has<semantics::ObjectEntityDetails>()) { 487 return std::nullopt; 488 } else { 489 return "dummy procedure argument"; 490 } 491 } else if (const auto *object{ 492 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) { 493 if (object->commonBlock()) { 494 return std::nullopt; 495 } 496 } 497 for (const semantics::Scope *s{&scope_}; !s->IsGlobal();) { 498 s = &s->parent(); 499 if (s == &ultimate.owner()) { 500 return std::nullopt; 501 } 502 } 503 return "reference to local entity '"s + ultimate.name().ToString() + "'"; 504 } 505 506 Result operator()(const Component &x) const { 507 // Don't look at the component symbol. 508 return (*this)(x.base()); 509 } 510 Result operator()(const DescriptorInquiry &) const { 511 // Subtle: Uses of SIZE(), LBOUND(), &c. that are valid in specification 512 // expressions will have been converted to expressions over descriptor 513 // inquiries by Fold(). 514 return std::nullopt; 515 } 516 517 Result operator()(const TypeParamInquiry &inq) const { 518 if (scope_.IsDerivedType() && !IsConstantExpr(inq) && 519 inq.base() /* X%T, not local T */) { // C750, C754 520 return "non-constant reference to a type parameter inquiry not " 521 "allowed for derived type components or type parameter values"; 522 } 523 return std::nullopt; 524 } 525 526 template <typename T> Result operator()(const FunctionRef<T> &x) const { 527 if (const auto *symbol{x.proc().GetSymbol()}) { 528 const Symbol &ultimate{symbol->GetUltimate()}; 529 if (!semantics::IsPureProcedure(ultimate)) { 530 return "reference to impure function '"s + ultimate.name().ToString() + 531 "'"; 532 } 533 if (semantics::IsStmtFunction(ultimate)) { 534 return "reference to statement function '"s + 535 ultimate.name().ToString() + "'"; 536 } 537 if (scope_.IsDerivedType()) { // C750, C754 538 return "reference to function '"s + ultimate.name().ToString() + 539 "' not allowed for derived type components or type parameter" 540 " values"; 541 } 542 // TODO: other checks for standard module procedures 543 } else { 544 const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; 545 if (scope_.IsDerivedType()) { // C750, C754 546 if ((context_.intrinsics().IsIntrinsic(intrin.name) && 547 badIntrinsicsForComponents_.find(intrin.name) != 548 badIntrinsicsForComponents_.end()) || 549 IsProhibitedFunction(intrin.name)) { 550 return "reference to intrinsic '"s + intrin.name + 551 "' not allowed for derived type components or type parameter" 552 " values"; 553 } 554 if (context_.intrinsics().GetIntrinsicClass(intrin.name) == 555 IntrinsicClass::inquiryFunction && 556 !IsConstantExpr(x)) { 557 return "non-constant reference to inquiry intrinsic '"s + 558 intrin.name + 559 "' not allowed for derived type components or type" 560 " parameter values"; 561 } 562 } else if (intrin.name == "present") { 563 return std::nullopt; // no need to check argument(s) 564 } 565 if (IsConstantExpr(x)) { 566 // inquiry functions may not need to check argument(s) 567 return std::nullopt; 568 } 569 } 570 return (*this)(x.arguments()); 571 } 572 573 private: 574 const semantics::Scope &scope_; 575 FoldingContext &context_; 576 const std::set<std::string> badIntrinsicsForComponents_{ 577 "allocated", "associated", "extends_type_of", "present", "same_type_as"}; 578 static bool IsProhibitedFunction(std::string name) { return false; } 579 }; 580 581 template <typename A> 582 void CheckSpecificationExpr( 583 const A &x, const semantics::Scope &scope, FoldingContext &context) { 584 if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) { 585 context.messages().Say( 586 "Invalid specification expression: %s"_err_en_US, *why); 587 } 588 } 589 590 template void CheckSpecificationExpr( 591 const Expr<SomeType> &, const semantics::Scope &, FoldingContext &); 592 template void CheckSpecificationExpr( 593 const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &); 594 template void CheckSpecificationExpr( 595 const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &); 596 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &, 597 const semantics::Scope &, FoldingContext &); 598 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &, 599 const semantics::Scope &, FoldingContext &); 600 template void CheckSpecificationExpr( 601 const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &, 602 FoldingContext &); 603 604 // IsSimplyContiguous() -- 9.5.4 605 class IsSimplyContiguousHelper 606 : public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> { 607 public: 608 using Result = std::optional<bool>; // tri-state 609 using Base = AnyTraverse<IsSimplyContiguousHelper, Result>; 610 explicit IsSimplyContiguousHelper(FoldingContext &c) 611 : Base{*this}, context_{c} {} 612 using Base::operator(); 613 614 Result operator()(const semantics::Symbol &symbol) const { 615 const auto &ultimate{symbol.GetUltimate()}; 616 if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS) || 617 ultimate.Rank() == 0) { 618 return true; 619 } else if (semantics::IsPointer(ultimate)) { 620 return false; 621 } else if (const auto *details{ 622 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) { 623 // N.B. ALLOCATABLEs are deferred shape, not assumed, and 624 // are obviously contiguous. 625 return !details->IsAssumedShape() && !details->IsAssumedRank(); 626 } else if (auto assoc{Base::operator()(ultimate)}) { 627 return assoc; 628 } else { 629 return false; 630 } 631 } 632 633 Result operator()(const ArrayRef &x) const { 634 const auto &symbol{x.GetLastSymbol()}; 635 if (!(*this)(symbol)) { 636 return false; 637 } else if (auto rank{CheckSubscripts(x.subscript())}) { 638 // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is 639 return *rank > 0 || x.Rank() == 0; 640 } else { 641 return false; 642 } 643 } 644 Result operator()(const CoarrayRef &x) const { 645 return CheckSubscripts(x.subscript()).has_value(); 646 } 647 Result operator()(const Component &x) const { 648 return x.base().Rank() == 0 && (*this)(x.GetLastSymbol()); 649 } 650 Result operator()(const ComplexPart &) const { return false; } 651 Result operator()(const Substring &) const { return false; } 652 653 template <typename T> Result operator()(const FunctionRef<T> &x) const { 654 if (auto chars{ 655 characteristics::Procedure::Characterize(x.proc(), context_)}) { 656 if (chars->functionResult) { 657 const auto &result{*chars->functionResult}; 658 return !result.IsProcedurePointer() && 659 result.attrs.test(characteristics::FunctionResult::Attr::Pointer) && 660 result.attrs.test( 661 characteristics::FunctionResult::Attr::Contiguous); 662 } 663 } 664 return false; 665 } 666 667 private: 668 // If the subscripts can possibly be on a simply-contiguous array reference, 669 // return the rank. 670 static std::optional<int> CheckSubscripts( 671 const std::vector<Subscript> &subscript) { 672 bool anyTriplet{false}; 673 int rank{0}; 674 for (auto j{subscript.size()}; j-- > 0;) { 675 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) { 676 if (!triplet->IsStrideOne()) { 677 return std::nullopt; 678 } else if (anyTriplet) { 679 if (triplet->lower() || triplet->upper()) { 680 // all triplets before the last one must be just ":" 681 return std::nullopt; 682 } 683 } else { 684 anyTriplet = true; 685 } 686 ++rank; 687 } else if (anyTriplet || subscript[j].Rank() > 0) { 688 return std::nullopt; 689 } 690 } 691 return rank; 692 } 693 694 FoldingContext &context_; 695 }; 696 697 template <typename A> 698 bool IsSimplyContiguous(const A &x, FoldingContext &context) { 699 if (IsVariable(x)) { 700 auto known{IsSimplyContiguousHelper{context}(x)}; 701 return known && *known; 702 } else { 703 return true; // not a variable 704 } 705 } 706 707 template bool IsSimplyContiguous(const Expr<SomeType> &, FoldingContext &); 708 709 // IsErrorExpr() 710 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> { 711 using Result = bool; 712 using Base = AnyTraverse<IsErrorExprHelper, Result>; 713 IsErrorExprHelper() : Base{*this} {} 714 using Base::operator(); 715 716 bool operator()(const SpecificIntrinsic &x) { 717 return x.name == IntrinsicProcTable::InvalidName; 718 } 719 }; 720 721 template <typename A> bool IsErrorExpr(const A &x) { 722 return IsErrorExprHelper{}(x); 723 } 724 725 template bool IsErrorExpr(const Expr<SomeType> &); 726 727 } // namespace Fortran::evaluate 728