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