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, "initialized object", 394 "initialization expression", false, false)) { 395 // make a constant array with adjusted lower bounds 396 return ArrayConstantBoundChanger{ 397 std::move(*AsConstantExtents( 398 context, GetLowerBounds(context, NamedEntity{symbol})))} 399 .ChangeLbounds(std::move(folded)); 400 } 401 } 402 } else if (IsNamedConstant(symbol)) { 403 if (IsExplicitShape(symbol)) { 404 context.messages().Say( 405 "Named constant '%s' array must have constant shape"_err_en_US, 406 symbol.name()); 407 } else { 408 // Declaration checking handles other cases 409 } 410 } else { 411 context.messages().Say( 412 "Shape of initialized object '%s' must be constant"_err_en_US, 413 symbol.name()); 414 } 415 } else if (IsErrorExpr(folded)) { 416 } else if (IsLenTypeParameter(symbol)) { 417 return {std::move(folded)}; 418 } else if (IsKindTypeParameter(symbol)) { 419 if (instantiation) { 420 context.messages().Say( 421 "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US, 422 symbol.name(), folded.AsFortran()); 423 } else { 424 return {std::move(folded)}; 425 } 426 } else if (IsNamedConstant(symbol)) { 427 context.messages().Say( 428 "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US, 429 symbol.name(), folded.AsFortran()); 430 } else { 431 context.messages().Say( 432 "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US, 433 symbol.name(), folded.AsFortran()); 434 } 435 } else if (xType) { 436 context.messages().Say( 437 "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US, 438 symbol.name(), xType->AsFortran()); 439 } else { 440 context.messages().Say( 441 "Initialization expression cannot be converted to declared type of '%s'"_err_en_US, 442 symbol.name()); 443 } 444 } 445 return std::nullopt; 446 } 447 448 // Specification expression validation (10.1.11(2), C1010) 449 class CheckSpecificationExprHelper 450 : public AnyTraverse<CheckSpecificationExprHelper, 451 std::optional<std::string>> { 452 public: 453 using Result = std::optional<std::string>; 454 using Base = AnyTraverse<CheckSpecificationExprHelper, Result>; 455 explicit CheckSpecificationExprHelper( 456 const semantics::Scope &s, FoldingContext &context) 457 : Base{*this}, scope_{s}, context_{context} {} 458 using Base::operator(); 459 460 Result operator()(const ProcedureDesignator &) const { 461 return "dummy procedure argument"; 462 } 463 Result operator()(const CoarrayRef &) const { return "coindexed reference"; } 464 465 Result operator()(const semantics::Symbol &symbol) const { 466 const auto &ultimate{symbol.GetUltimate()}; 467 if (const auto *assoc{ 468 ultimate.detailsIf<semantics::AssocEntityDetails>()}) { 469 return (*this)(assoc->expr()); 470 } else if (semantics::IsNamedConstant(ultimate) || 471 ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) { 472 return std::nullopt; 473 } else if (scope_.IsDerivedType() && 474 IsVariableName(ultimate)) { // C750, C754 475 return "derived type component or type parameter value not allowed to " 476 "reference variable '"s + 477 ultimate.name().ToString() + "'"; 478 } else if (IsDummy(ultimate)) { 479 if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) { 480 return "reference to OPTIONAL dummy argument '"s + 481 ultimate.name().ToString() + "'"; 482 } else if (ultimate.attrs().test(semantics::Attr::INTENT_OUT)) { 483 return "reference to INTENT(OUT) dummy argument '"s + 484 ultimate.name().ToString() + "'"; 485 } else if (ultimate.has<semantics::ObjectEntityDetails>()) { 486 return std::nullopt; 487 } else { 488 return "dummy procedure argument"; 489 } 490 } else if (const auto *object{ 491 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) { 492 if (object->commonBlock()) { 493 return std::nullopt; 494 } 495 } 496 for (const semantics::Scope *s{&scope_}; !s->IsGlobal();) { 497 s = &s->parent(); 498 if (s == &ultimate.owner()) { 499 return std::nullopt; 500 } 501 } 502 return "reference to local entity '"s + ultimate.name().ToString() + "'"; 503 } 504 505 Result operator()(const Component &x) const { 506 // Don't look at the component symbol. 507 return (*this)(x.base()); 508 } 509 Result operator()(const DescriptorInquiry &) const { 510 // Subtle: Uses of SIZE(), LBOUND(), &c. that are valid in specification 511 // expressions will have been converted to expressions over descriptor 512 // inquiries by Fold(). 513 return std::nullopt; 514 } 515 516 Result operator()(const TypeParamInquiry &inq) const { 517 if (scope_.IsDerivedType() && !IsConstantExpr(inq) && 518 inq.base() /* X%T, not local T */) { // C750, C754 519 return "non-constant reference to a type parameter inquiry not " 520 "allowed for derived type components or type parameter values"; 521 } 522 return std::nullopt; 523 } 524 525 template <typename T> Result operator()(const FunctionRef<T> &x) const { 526 if (const auto *symbol{x.proc().GetSymbol()}) { 527 const Symbol &ultimate{symbol->GetUltimate()}; 528 if (!semantics::IsPureProcedure(ultimate)) { 529 return "reference to impure function '"s + ultimate.name().ToString() + 530 "'"; 531 } 532 if (semantics::IsStmtFunction(ultimate)) { 533 return "reference to statement function '"s + 534 ultimate.name().ToString() + "'"; 535 } 536 if (scope_.IsDerivedType()) { // C750, C754 537 return "reference to function '"s + ultimate.name().ToString() + 538 "' not allowed for derived type components or type parameter" 539 " values"; 540 } 541 // TODO: other checks for standard module procedures 542 } else { 543 const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; 544 if (scope_.IsDerivedType()) { // C750, C754 545 if ((context_.intrinsics().IsIntrinsic(intrin.name) && 546 badIntrinsicsForComponents_.find(intrin.name) != 547 badIntrinsicsForComponents_.end()) || 548 IsProhibitedFunction(intrin.name)) { 549 return "reference to intrinsic '"s + intrin.name + 550 "' not allowed for derived type components or type parameter" 551 " values"; 552 } 553 if (context_.intrinsics().GetIntrinsicClass(intrin.name) == 554 IntrinsicClass::inquiryFunction && 555 !IsConstantExpr(x)) { 556 return "non-constant reference to inquiry intrinsic '"s + 557 intrin.name + 558 "' not allowed for derived type components or type" 559 " parameter values"; 560 } 561 } else if (intrin.name == "present") { 562 return std::nullopt; // no need to check argument(s) 563 } 564 if (IsConstantExpr(x)) { 565 // inquiry functions may not need to check argument(s) 566 return std::nullopt; 567 } 568 } 569 return (*this)(x.arguments()); 570 } 571 572 private: 573 const semantics::Scope &scope_; 574 FoldingContext &context_; 575 const std::set<std::string> badIntrinsicsForComponents_{ 576 "allocated", "associated", "extends_type_of", "present", "same_type_as"}; 577 static bool IsProhibitedFunction(std::string name) { return false; } 578 }; 579 580 template <typename A> 581 void CheckSpecificationExpr( 582 const A &x, const semantics::Scope &scope, FoldingContext &context) { 583 if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) { 584 context.messages().Say( 585 "Invalid specification expression: %s"_err_en_US, *why); 586 } 587 } 588 589 template void CheckSpecificationExpr( 590 const Expr<SomeType> &, const semantics::Scope &, FoldingContext &); 591 template void CheckSpecificationExpr( 592 const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &); 593 template void CheckSpecificationExpr( 594 const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &); 595 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &, 596 const semantics::Scope &, FoldingContext &); 597 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &, 598 const semantics::Scope &, FoldingContext &); 599 template void CheckSpecificationExpr( 600 const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &, 601 FoldingContext &); 602 603 // IsSimplyContiguous() -- 9.5.4 604 class IsSimplyContiguousHelper 605 : public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> { 606 public: 607 using Result = std::optional<bool>; // tri-state 608 using Base = AnyTraverse<IsSimplyContiguousHelper, Result>; 609 explicit IsSimplyContiguousHelper(FoldingContext &c) 610 : Base{*this}, context_{c} {} 611 using Base::operator(); 612 613 Result operator()(const semantics::Symbol &symbol) const { 614 const auto &ultimate{symbol.GetUltimate()}; 615 if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS) || 616 ultimate.Rank() == 0) { 617 return true; 618 } else if (semantics::IsPointer(ultimate)) { 619 return false; 620 } else if (const auto *details{ 621 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) { 622 // N.B. ALLOCATABLEs are deferred shape, not assumed, and 623 // are obviously contiguous. 624 return !details->IsAssumedShape() && !details->IsAssumedRank(); 625 } else if (auto assoc{Base::operator()(ultimate)}) { 626 return assoc; 627 } else { 628 return false; 629 } 630 } 631 632 Result operator()(const ArrayRef &x) const { 633 const auto &symbol{x.GetLastSymbol()}; 634 if (!(*this)(symbol)) { 635 return false; 636 } else if (auto rank{CheckSubscripts(x.subscript())}) { 637 // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is 638 return *rank > 0 || x.Rank() == 0; 639 } else { 640 return false; 641 } 642 } 643 Result operator()(const CoarrayRef &x) const { 644 return CheckSubscripts(x.subscript()).has_value(); 645 } 646 Result operator()(const Component &x) const { 647 return x.base().Rank() == 0 && (*this)(x.GetLastSymbol()); 648 } 649 Result operator()(const ComplexPart &) const { return false; } 650 Result operator()(const Substring &) const { return false; } 651 652 template <typename T> Result operator()(const FunctionRef<T> &x) const { 653 if (auto chars{ 654 characteristics::Procedure::Characterize(x.proc(), context_)}) { 655 if (chars->functionResult) { 656 const auto &result{*chars->functionResult}; 657 return !result.IsProcedurePointer() && 658 result.attrs.test(characteristics::FunctionResult::Attr::Pointer) && 659 result.attrs.test( 660 characteristics::FunctionResult::Attr::Contiguous); 661 } 662 } 663 return false; 664 } 665 666 private: 667 // If the subscripts can possibly be on a simply-contiguous array reference, 668 // return the rank. 669 static std::optional<int> CheckSubscripts( 670 const std::vector<Subscript> &subscript) { 671 bool anyTriplet{false}; 672 int rank{0}; 673 for (auto j{subscript.size()}; j-- > 0;) { 674 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) { 675 if (!triplet->IsStrideOne()) { 676 return std::nullopt; 677 } else if (anyTriplet) { 678 if (triplet->lower() || triplet->upper()) { 679 // all triplets before the last one must be just ":" 680 return std::nullopt; 681 } 682 } else { 683 anyTriplet = true; 684 } 685 ++rank; 686 } else if (anyTriplet || subscript[j].Rank() > 0) { 687 return std::nullopt; 688 } 689 } 690 return rank; 691 } 692 693 FoldingContext &context_; 694 }; 695 696 template <typename A> 697 bool IsSimplyContiguous(const A &x, FoldingContext &context) { 698 if (IsVariable(x)) { 699 auto known{IsSimplyContiguousHelper{context}(x)}; 700 return known && *known; 701 } else { 702 return true; // not a variable 703 } 704 } 705 706 template bool IsSimplyContiguous(const Expr<SomeType> &, FoldingContext &); 707 708 // IsErrorExpr() 709 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> { 710 using Result = bool; 711 using Base = AnyTraverse<IsErrorExprHelper, Result>; 712 IsErrorExprHelper() : Base{*this} {} 713 using Base::operator(); 714 715 bool operator()(const SpecificIntrinsic &x) { 716 return x.name == IntrinsicProcTable::InvalidName; 717 } 718 }; 719 720 template <typename A> bool IsErrorExpr(const A &x) { 721 return IsErrorExprHelper{}(x); 722 } 723 724 template bool IsErrorExpr(const Expr<SomeType> &); 725 726 } // namespace Fortran::evaluate 727