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 rewritten 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 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 if (auto procChars{ 542 characteristics::Procedure::Characterize(x.proc(), context_)}) { 543 const auto iter{std::find_if(procChars->dummyArguments.begin(), 544 procChars->dummyArguments.end(), 545 [](const characteristics::DummyArgument &dummy) { 546 return std::holds_alternative<characteristics::DummyProcedure>( 547 dummy.u); 548 })}; 549 if (iter != procChars->dummyArguments.end()) { 550 return "reference to function '"s + ultimate.name().ToString() + 551 "' with dummy procedure argument '" + iter->name + '\''; 552 } 553 } 554 // References to internal functions are caught in expression semantics. 555 // TODO: other checks for standard module procedures 556 } else { 557 const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; 558 if (scope_.IsDerivedType()) { // C750, C754 559 if ((context_.intrinsics().IsIntrinsic(intrin.name) && 560 badIntrinsicsForComponents_.find(intrin.name) != 561 badIntrinsicsForComponents_.end()) || 562 IsProhibitedFunction(intrin.name)) { 563 return "reference to intrinsic '"s + intrin.name + 564 "' not allowed for derived type components or type parameter" 565 " values"; 566 } 567 if (context_.intrinsics().GetIntrinsicClass(intrin.name) == 568 IntrinsicClass::inquiryFunction && 569 !IsConstantExpr(x)) { 570 return "non-constant reference to inquiry intrinsic '"s + 571 intrin.name + 572 "' not allowed for derived type components or type" 573 " parameter values"; 574 } 575 } else if (intrin.name == "present") { 576 return std::nullopt; // no need to check argument(s) 577 } 578 if (IsConstantExpr(x)) { 579 // inquiry functions may not need to check argument(s) 580 return std::nullopt; 581 } 582 } 583 return (*this)(x.arguments()); 584 } 585 586 private: 587 const semantics::Scope &scope_; 588 FoldingContext &context_; 589 const std::set<std::string> badIntrinsicsForComponents_{ 590 "allocated", "associated", "extends_type_of", "present", "same_type_as"}; 591 static bool IsProhibitedFunction(std::string name) { return false; } 592 }; 593 594 template <typename A> 595 void CheckSpecificationExpr( 596 const A &x, const semantics::Scope &scope, FoldingContext &context) { 597 if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) { 598 context.messages().Say( 599 "Invalid specification expression: %s"_err_en_US, *why); 600 } 601 } 602 603 template void CheckSpecificationExpr( 604 const Expr<SomeType> &, const semantics::Scope &, FoldingContext &); 605 template void CheckSpecificationExpr( 606 const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &); 607 template void CheckSpecificationExpr( 608 const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &); 609 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &, 610 const semantics::Scope &, FoldingContext &); 611 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &, 612 const semantics::Scope &, FoldingContext &); 613 template void CheckSpecificationExpr( 614 const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &, 615 FoldingContext &); 616 617 // IsSimplyContiguous() -- 9.5.4 618 class IsSimplyContiguousHelper 619 : public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> { 620 public: 621 using Result = std::optional<bool>; // tri-state 622 using Base = AnyTraverse<IsSimplyContiguousHelper, Result>; 623 explicit IsSimplyContiguousHelper(FoldingContext &c) 624 : Base{*this}, context_{c} {} 625 using Base::operator(); 626 627 Result operator()(const semantics::Symbol &symbol) const { 628 const auto &ultimate{symbol.GetUltimate()}; 629 if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) { 630 return true; 631 } else if (ultimate.Rank() == 0) { 632 // Extension: accept scalars as a degenerate case of 633 // simple contiguity to allow their use in contexts like 634 // data targets in pointer assignments with remapping. 635 return true; 636 } else if (semantics::IsPointer(ultimate)) { 637 return false; 638 } else if (const auto *details{ 639 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) { 640 // N.B. ALLOCATABLEs are deferred shape, not assumed, and 641 // are obviously contiguous. 642 return !details->IsAssumedShape() && !details->IsAssumedRank(); 643 } else if (auto assoc{Base::operator()(ultimate)}) { 644 return assoc; 645 } else { 646 return false; 647 } 648 } 649 650 Result operator()(const ArrayRef &x) const { 651 const auto &symbol{x.GetLastSymbol()}; 652 if (!(*this)(symbol).has_value()) { 653 return false; 654 } else if (auto rank{CheckSubscripts(x.subscript())}) { 655 // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is 656 return *rank > 0 || x.Rank() == 0; 657 } else { 658 return false; 659 } 660 } 661 Result operator()(const CoarrayRef &x) const { 662 return CheckSubscripts(x.subscript()).has_value(); 663 } 664 Result operator()(const Component &x) const { 665 return x.base().Rank() == 0 && (*this)(x.GetLastSymbol()).value_or(false); 666 } 667 Result operator()(const ComplexPart &) const { return false; } 668 Result operator()(const Substring &) const { return false; } 669 670 template <typename T> Result operator()(const FunctionRef<T> &x) const { 671 if (auto chars{ 672 characteristics::Procedure::Characterize(x.proc(), context_)}) { 673 if (chars->functionResult) { 674 const auto &result{*chars->functionResult}; 675 return !result.IsProcedurePointer() && 676 result.attrs.test(characteristics::FunctionResult::Attr::Pointer) && 677 result.attrs.test( 678 characteristics::FunctionResult::Attr::Contiguous); 679 } 680 } 681 return false; 682 } 683 684 private: 685 // If the subscripts can possibly be on a simply-contiguous array reference, 686 // return the rank. 687 static std::optional<int> CheckSubscripts( 688 const std::vector<Subscript> &subscript) { 689 bool anyTriplet{false}; 690 int rank{0}; 691 for (auto j{subscript.size()}; j-- > 0;) { 692 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) { 693 if (!triplet->IsStrideOne()) { 694 return std::nullopt; 695 } else if (anyTriplet) { 696 if (triplet->lower() || triplet->upper()) { 697 // all triplets before the last one must be just ":" 698 return std::nullopt; 699 } 700 } else { 701 anyTriplet = true; 702 } 703 ++rank; 704 } else if (anyTriplet || subscript[j].Rank() > 0) { 705 return std::nullopt; 706 } 707 } 708 return rank; 709 } 710 711 FoldingContext &context_; 712 }; 713 714 template <typename A> 715 bool IsSimplyContiguous(const A &x, FoldingContext &context) { 716 if (IsVariable(x)) { 717 auto known{IsSimplyContiguousHelper{context}(x)}; 718 return known && *known; 719 } else { 720 return true; // not a variable 721 } 722 } 723 724 template bool IsSimplyContiguous(const Expr<SomeType> &, FoldingContext &); 725 726 // IsErrorExpr() 727 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> { 728 using Result = bool; 729 using Base = AnyTraverse<IsErrorExprHelper, Result>; 730 IsErrorExprHelper() : Base{*this} {} 731 using Base::operator(); 732 733 bool operator()(const SpecificIntrinsic &x) { 734 return x.name == IntrinsicProcTable::InvalidName; 735 } 736 }; 737 738 template <typename A> bool IsErrorExpr(const A &x) { 739 return IsErrorExprHelper{}(x); 740 } 741 742 template bool IsErrorExpr(const Expr<SomeType> &); 743 744 } // namespace Fortran::evaluate 745