1632 lines · cpp
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-exception6//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/tools.h"13#include "flang/Evaluate/traverse.h"14#include "flang/Evaluate/type.h"15#include "flang/Semantics/semantics.h"16#include "flang/Semantics/symbol.h"17#include "flang/Semantics/tools.h"18#include <set>19#include <string>20 21namespace Fortran::evaluate {22 23// Constant expression predicates IsConstantExpr() & IsScopeInvariantExpr().24// This code determines whether an expression is a "constant expression"25// in the sense of section 10.1.12. This is not the same thing as being26// able to fold it (yet) into a known constant value; specifically,27// the expression may reference derived type kind parameters whose values28// are not yet known.29//30// The variant form (IsScopeInvariantExpr()) also accepts symbols that are31// INTENT(IN) dummy arguments without the VALUE attribute.32template <bool INVARIANT>33class IsConstantExprHelper34 : public AllTraverse<IsConstantExprHelper<INVARIANT>, true> {35public:36 using Base = AllTraverse<IsConstantExprHelper, true>;37 IsConstantExprHelper() : Base{*this} {}38 using Base::operator();39 40 // A missing expression is not considered to be constant.41 template <typename A> bool operator()(const std::optional<A> &x) const {42 return x && (*this)(*x);43 }44 45 bool operator()(const TypeParamInquiry &inq) const {46 return INVARIANT || semantics::IsKindTypeParameter(inq.parameter());47 }48 bool operator()(const semantics::Symbol &symbol) const {49 const auto &ultimate{GetAssociationRoot(symbol)};50 return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||51 IsInitialProcedureTarget(ultimate) ||52 ultimate.has<semantics::TypeParamDetails>() ||53 (INVARIANT && IsIntentIn(symbol) && !IsOptional(symbol) &&54 !symbol.attrs().test(semantics::Attr::VALUE));55 }56 bool operator()(const CoarrayRef &) const { return false; }57 bool operator()(const semantics::ParamValue ¶m) const {58 return param.isExplicit() && (*this)(param.GetExplicit());59 }60 bool operator()(const ProcedureRef &) const;61 bool operator()(const StructureConstructor &constructor) const {62 for (const auto &[symRef, expr] : constructor) {63 if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {64 return false;65 }66 }67 return true;68 }69 bool operator()(const Component &component) const {70 return (*this)(component.base());71 }72 // Prevent integer division by known zeroes in constant expressions.73 template <int KIND>74 bool operator()(75 const Divide<Type<TypeCategory::Integer, KIND>> &division) const {76 using T = Type<TypeCategory::Integer, KIND>;77 if ((*this)(division.left()) && (*this)(division.right())) {78 const auto divisor{GetScalarConstantValue<T>(division.right())};79 return !divisor || !divisor->IsZero();80 } else {81 return false;82 }83 }84 85 bool operator()(const Constant<SomeDerived> &) const { return true; }86 bool operator()(const DescriptorInquiry &x) const {87 const Symbol &sym{x.base().GetLastSymbol()};88 return INVARIANT && !IsAllocatable(sym) &&89 (!IsDummy(sym) ||90 (IsIntentIn(sym) && !IsOptional(sym) &&91 !sym.attrs().test(semantics::Attr::VALUE)));92 }93 94private:95 bool IsConstantStructureConstructorComponent(96 const Symbol &, const Expr<SomeType> &) const;97 bool IsConstantExprShape(const Shape &) const;98};99 100template <bool INVARIANT>101bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(102 const Symbol &component, const Expr<SomeType> &expr) const {103 if (IsAllocatable(component)) {104 return IsNullObjectPointer(&expr);105 } else if (IsPointer(component)) {106 return IsNullPointerOrAllocatable(&expr) || IsInitialDataTarget(expr) ||107 IsInitialProcedureTarget(expr);108 } else {109 return (*this)(expr);110 }111}112 113template <bool INVARIANT>114bool IsConstantExprHelper<INVARIANT>::operator()(115 const ProcedureRef &call) const {116 // LBOUND, UBOUND, and SIZE with truly constant DIM= arguments will have117 // been rewritten into DescriptorInquiry operations.118 if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {119 const characteristics::Procedure &proc{intrinsic->characteristics.value()};120 if (intrinsic->name == "kind" ||121 intrinsic->name == IntrinsicProcTable::InvalidName ||122 call.arguments().empty() || !call.arguments()[0]) {123 // kind is always a constant, and we avoid cascading errors by considering124 // invalid calls to intrinsics to be constant125 return true;126 } else if (intrinsic->name == "lbound") {127 auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};128 return base && IsConstantExprShape(GetLBOUNDs(*base));129 } else if (intrinsic->name == "ubound") {130 auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};131 return base && IsConstantExprShape(GetUBOUNDs(*base));132 } else if (intrinsic->name == "shape" || intrinsic->name == "size") {133 auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};134 return shape && IsConstantExprShape(*shape);135 } else if (proc.IsPure()) {136 std::size_t j{0};137 for (const auto &arg : call.arguments()) {138 const auto *dataDummy{j < proc.dummyArguments.size()139 ? std::get_if<characteristics::DummyDataObject>(140 &proc.dummyArguments[j].u)141 : nullptr};142 if (dataDummy &&143 dataDummy->attrs.test(144 characteristics::DummyDataObject::Attr::OnlyIntrinsicInquiry)) {145 // The value of the argument doesn't matter146 } else if (!arg) {147 if (dataDummy &&148 dataDummy->attrs.test(149 characteristics::DummyDataObject::Attr::Optional)) {150 // Missing optional arguments are okay.151 } else {152 return false;153 }154 } else if (const auto *expr{arg->UnwrapExpr()};155 !expr || !(*this)(*expr)) {156 return false;157 }158 ++j;159 }160 return true;161 }162 // TODO: STORAGE_SIZE163 }164 return false;165}166 167template <bool INVARIANT>168bool IsConstantExprHelper<INVARIANT>::IsConstantExprShape(169 const Shape &shape) const {170 for (const auto &extent : shape) {171 if (!(*this)(extent)) {172 return false;173 }174 }175 return true;176}177 178template <typename A> bool IsConstantExpr(const A &x) {179 return IsConstantExprHelper<false>{}(x);180}181template bool IsConstantExpr(const Expr<SomeType> &);182template bool IsConstantExpr(const Expr<SomeInteger> &);183template bool IsConstantExpr(const Expr<SubscriptInteger> &);184template bool IsConstantExpr(const StructureConstructor &);185 186// IsScopeInvariantExpr()187template <typename A> bool IsScopeInvariantExpr(const A &x) {188 return IsConstantExprHelper<true>{}(x);189}190template bool IsScopeInvariantExpr(const Expr<SomeType> &);191template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);192template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);193 194// IsActuallyConstant()195struct IsActuallyConstantHelper {196 template <typename A> bool operator()(const A &) { return false; }197 template <typename T> bool operator()(const Constant<T> &) { return true; }198 template <typename T> bool operator()(const Parentheses<T> &x) {199 return (*this)(x.left());200 }201 template <typename T> bool operator()(const Expr<T> &x) {202 return common::visit([=](const auto &y) { return (*this)(y); }, x.u);203 }204 bool operator()(const Expr<SomeType> &x) {205 return common::visit([this](const auto &y) { return (*this)(y); }, x.u);206 }207 bool operator()(const StructureConstructor &x) {208 for (const auto &pair : x) {209 const Expr<SomeType> &y{pair.second.value()};210 const auto sym{pair.first};211 const bool compIsConstant{(*this)(y)};212 // If an allocatable component is initialized by a constant,213 // the structure constructor is not a constant.214 if ((!compIsConstant && !IsNullPointerOrAllocatable(&y)) ||215 (compIsConstant && IsAllocatable(sym))) {216 return false;217 }218 }219 return true;220 }221 template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }222 template <typename A> bool operator()(const std::optional<A> &x) {223 return x && (*this)(*x);224 }225};226 227template <typename A> bool IsActuallyConstant(const A &x) {228 return IsActuallyConstantHelper{}(x);229}230 231template bool IsActuallyConstant(const Expr<SomeType> &);232template bool IsActuallyConstant(const Expr<SomeInteger> &);233template bool IsActuallyConstant(const Expr<SubscriptInteger> &);234template bool IsActuallyConstant(const std::optional<Expr<SubscriptInteger>> &);235 236// Object pointer initialization checking predicate IsInitialDataTarget().237// This code determines whether an expression is allowable as the static238// data address used to initialize a pointer with "=> x". See C765.239class IsInitialDataTargetHelper240 : public AllTraverse<IsInitialDataTargetHelper, true> {241public:242 using Base = AllTraverse<IsInitialDataTargetHelper, true>;243 using Base::operator();244 explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)245 : Base{*this}, messages_{m} {}246 247 bool emittedMessage() const { return emittedMessage_; }248 249 bool operator()(const BOZLiteralConstant &) const { return false; }250 bool operator()(const NullPointer &) const { return true; }251 template <typename T> bool operator()(const Constant<T> &) const {252 return false;253 }254 bool operator()(const semantics::Symbol &symbol) {255 // This function checks only base symbols, not components.256 const Symbol &ultimate{symbol.GetUltimate()};257 if (const auto *assoc{258 ultimate.detailsIf<semantics::AssocEntityDetails>()}) {259 if (const auto &expr{assoc->expr()}) {260 if (IsVariable(*expr)) {261 return (*this)(*expr);262 } else if (messages_) {263 messages_->Say(264 "An initial data target may not be an associated expression ('%s')"_err_en_US,265 ultimate.name());266 emittedMessage_ = true;267 }268 }269 return false;270 } else if (!CheckVarOrComponent(ultimate)) {271 return false;272 } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {273 if (messages_) {274 messages_->Say(275 "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,276 ultimate.name());277 emittedMessage_ = true;278 }279 return false;280 } else if (!IsSaved(ultimate)) {281 if (messages_) {282 messages_->Say(283 "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,284 ultimate.name());285 emittedMessage_ = true;286 }287 return false;288 } else {289 return true;290 }291 }292 bool operator()(const StaticDataObject &) const { return false; }293 bool operator()(const TypeParamInquiry &) const { return false; }294 bool operator()(const Triplet &x) const {295 return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&296 IsConstantExpr(x.stride());297 }298 bool operator()(const Subscript &x) const {299 return common::visit(common::visitors{300 [&](const Triplet &t) { return (*this)(t); },301 [&](const auto &y) {302 return y.value().Rank() == 0 &&303 IsConstantExpr(y.value());304 },305 },306 x.u);307 }308 bool operator()(const CoarrayRef &) const { return false; }309 bool operator()(const Component &x) {310 return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base());311 }312 bool operator()(const Substring &x) const {313 return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&314 (*this)(x.parent());315 }316 bool operator()(const DescriptorInquiry &) const { return false; }317 template <typename T> bool operator()(const ArrayConstructor<T> &) const {318 return false;319 }320 bool operator()(const StructureConstructor &) const { return false; }321 template <typename D, typename R, typename... O>322 bool operator()(const Operation<D, R, O...> &) const {323 return false;324 }325 template <typename T> bool operator()(const Parentheses<T> &x) const {326 return (*this)(x.left());327 }328 bool operator()(const ProcedureRef &x) const {329 if (const SpecificIntrinsic * intrinsic{x.proc().GetSpecificIntrinsic()}) {330 return intrinsic->characteristics.value().attrs.test(331 characteristics::Procedure::Attr::NullPointer) ||332 intrinsic->characteristics.value().attrs.test(333 characteristics::Procedure::Attr::NullAllocatable);334 }335 return false;336 }337 bool operator()(const Relational<SomeType> &) const { return false; }338 339private:340 bool CheckVarOrComponent(const semantics::Symbol &symbol) {341 const Symbol &ultimate{symbol.GetUltimate()};342 const char *unacceptable{nullptr};343 if (ultimate.Corank() > 0) {344 unacceptable = "a coarray";345 } else if (IsAllocatable(ultimate)) {346 unacceptable = "an ALLOCATABLE";347 } else if (IsPointer(ultimate)) {348 unacceptable = "a POINTER";349 } else {350 return true;351 }352 if (messages_) {353 messages_->Say(354 "An initial data target may not be a reference to %s '%s'"_err_en_US,355 unacceptable, ultimate.name());356 emittedMessage_ = true;357 }358 return false;359 }360 361 parser::ContextualMessages *messages_;362 bool emittedMessage_{false};363};364 365bool IsInitialDataTarget(366 const Expr<SomeType> &x, parser::ContextualMessages *messages) {367 IsInitialDataTargetHelper helper{messages};368 bool result{helper(x)};369 if (!result && messages && !helper.emittedMessage()) {370 messages->Say(371 "An initial data target must be a designator with constant subscripts"_err_en_US);372 }373 return result;374}375 376bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {377 const auto &ultimate{symbol.GetUltimate()};378 return common::visit(379 common::visitors{380 [&](const semantics::SubprogramDetails &subp) {381 return !subp.isDummy() && !subp.stmtFunction() &&382 ((symbol.owner().kind() !=383 semantics::Scope::Kind::MainProgram &&384 symbol.owner().kind() !=385 semantics::Scope::Kind::Subprogram) ||386 ultimate.attrs().test(semantics::Attr::EXTERNAL));387 },388 [](const semantics::SubprogramNameDetails &x) {389 return x.kind() != semantics::SubprogramKind::Internal;390 },391 [&](const semantics::ProcEntityDetails &proc) {392 return !semantics::IsPointer(ultimate) && !proc.isDummy();393 },394 [](const auto &) { return false; },395 },396 ultimate.details());397}398 399bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {400 if (const auto *intrin{proc.GetSpecificIntrinsic()}) {401 return !intrin->isRestrictedSpecific;402 } else if (proc.GetComponent()) {403 return false;404 } else {405 return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));406 }407}408 409bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {410 if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {411 return IsInitialProcedureTarget(*proc);412 } else {413 return IsNullProcedurePointer(&expr);414 }415}416 417class SuspiciousRealLiteralFinder418 : public AnyTraverse<SuspiciousRealLiteralFinder> {419public:420 using Base = AnyTraverse<SuspiciousRealLiteralFinder>;421 SuspiciousRealLiteralFinder(int kind, FoldingContext &c)422 : Base{*this}, kind_{kind}, context_{c} {}423 using Base::operator();424 template <int KIND>425 bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &x) const {426 if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) {427 context_.Warn(common::UsageWarning::RealConstantWidening,428 "Default real literal in REAL(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US,429 kind_, x.AsFortran());430 return true;431 } else {432 return false;433 }434 }435 template <int KIND>436 bool operator()(const Constant<Type<TypeCategory::Complex, KIND>> &x) const {437 if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) {438 context_.Warn(common::UsageWarning::RealConstantWidening,439 "Default real literal in COMPLEX(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US,440 kind_, x.AsFortran());441 return true;442 } else {443 return false;444 }445 }446 template <TypeCategory TOCAT, int TOKIND, TypeCategory FROMCAT>447 bool operator()(const Convert<Type<TOCAT, TOKIND>, FROMCAT> &x) const {448 if constexpr ((TOCAT == TypeCategory::Real ||449 TOCAT == TypeCategory::Complex) &&450 (FROMCAT == TypeCategory::Real || FROMCAT == TypeCategory::Complex)) {451 auto fromType{x.left().GetType()};452 if (!fromType || fromType->kind() < TOKIND) {453 return false;454 }455 }456 return (*this)(x.left());457 }458 459private:460 int kind_;461 FoldingContext &context_;462};463 464void CheckRealWidening(const Expr<SomeType> &expr, const DynamicType &toType,465 FoldingContext &context) {466 if (toType.category() == TypeCategory::Real ||467 toType.category() == TypeCategory::Complex) {468 if (auto fromType{expr.GetType()}) {469 if ((fromType->category() == TypeCategory::Real ||470 fromType->category() == TypeCategory::Complex) &&471 toType.kind() > fromType->kind()) {472 SuspiciousRealLiteralFinder{toType.kind(), context}(expr);473 }474 }475 }476}477 478void CheckRealWidening(const Expr<SomeType> &expr,479 const std::optional<DynamicType> &toType, FoldingContext &context) {480 if (toType) {481 CheckRealWidening(expr, *toType, context);482 }483}484 485class InexactLiteralConversionFlagClearer486 : public AnyTraverse<InexactLiteralConversionFlagClearer> {487public:488 using Base = AnyTraverse<InexactLiteralConversionFlagClearer>;489 InexactLiteralConversionFlagClearer() : Base(*this) {}490 using Base::operator();491 template <int KIND>492 bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &x) const {493 auto &mut{const_cast<Type<TypeCategory::Real, KIND> &>(x.result())};494 mut.set_isFromInexactLiteralConversion(false);495 return false;496 }497};498 499// Converts, folds, and then checks type, rank, and shape of an500// initialization expression for a named constant, a non-pointer501// variable static initialization, a component default initializer,502// a type parameter default value, or instantiated type parameter value.503std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,504 Expr<SomeType> &&x, FoldingContext &context,505 const semantics::Scope *instantiation) {506 CHECK(!IsPointer(symbol));507 if (auto symTS{508 characteristics::TypeAndShape::Characterize(symbol, context)}) {509 auto xType{x.GetType()};510 CheckRealWidening(x, symTS->type(), context);511 auto converted{ConvertToType(symTS->type(), Expr<SomeType>{x})};512 if (!converted &&513 symbol.owner().context().IsEnabled(514 common::LanguageFeature::LogicalIntegerAssignment)) {515 converted = DataConstantConversionExtension(context, symTS->type(), x);516 if (converted) {517 context.Warn(common::LanguageFeature::LogicalIntegerAssignment,518 "nonstandard usage: initialization of %s with %s"_port_en_US,519 symTS->type().AsFortran(), x.GetType().value().AsFortran());520 }521 }522 if (converted) {523 auto folded{Fold(context, std::move(*converted))};524 if (IsActuallyConstant(folded)) {525 InexactLiteralConversionFlagClearer{}(folded);526 int symRank{symTS->Rank()};527 if (IsImpliedShape(symbol)) {528 if (folded.Rank() == symRank) {529 return ArrayConstantBoundChanger{530 std::move(*AsConstantExtents(531 context, GetRawLowerBounds(context, NamedEntity{symbol})))}532 .ChangeLbounds(std::move(folded));533 } else {534 context.messages().Say(535 "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,536 symbol.name(), symRank, folded.Rank());537 }538 } else if (auto extents{AsConstantExtents(context, symTS->shape())};539 extents && !HasNegativeExtent(*extents)) {540 if (folded.Rank() == 0 && symRank == 0) {541 // symbol and constant are both scalars542 return {std::move(folded)};543 } else if (folded.Rank() == 0 && symRank > 0) {544 // expand the scalar constant to an array545 return ScalarConstantExpander{std::move(*extents),546 AsConstantExtents(547 context, GetRawLowerBounds(context, NamedEntity{symbol}))}548 .Expand(std::move(folded));549 } else if (auto resultShape{GetShape(context, folded)}) {550 CHECK(symTS->shape()); // Assumed-ranks cannot be initialized.551 if (CheckConformance(context.messages(), *symTS->shape(),552 *resultShape, CheckConformanceFlags::None,553 "initialized object", "initialization expression")554 .value_or(false /*fail if not known now to conform*/)) {555 // make a constant array with adjusted lower bounds556 return ArrayConstantBoundChanger{557 std::move(*AsConstantExtents(context,558 GetRawLowerBounds(context, NamedEntity{symbol})))}559 .ChangeLbounds(std::move(folded));560 }561 }562 } else if (IsNamedConstant(symbol)) {563 if (IsExplicitShape(symbol)) {564 context.messages().Say(565 "Named constant '%s' array must have constant shape"_err_en_US,566 symbol.name());567 } else {568 // Declaration checking handles other cases569 }570 } else {571 context.messages().Say(572 "Shape of initialized object '%s' must be constant"_err_en_US,573 symbol.name());574 }575 } else if (IsErrorExpr(folded)) {576 } else if (IsLenTypeParameter(symbol)) {577 return {std::move(folded)};578 } else if (IsKindTypeParameter(symbol)) {579 if (instantiation) {580 context.messages().Say(581 "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,582 symbol.name(), folded.AsFortran());583 } else {584 return {std::move(folded)};585 }586 } else if (IsNamedConstant(symbol)) {587 if (symbol.name() == "numeric_storage_size" &&588 symbol.owner().IsModule() &&589 DEREF(symbol.owner().symbol()).name() == "iso_fortran_env") {590 // Very special case: numeric_storage_size is not folded until591 // it read from the iso_fortran_env module file, as its value592 // depends on compilation options.593 return {std::move(folded)};594 }595 context.messages().Say(596 "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,597 symbol.name(), folded.AsFortran());598 } else {599 context.messages().Say(600 "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,601 symbol.name(), x.AsFortran());602 }603 } else if (xType) {604 context.messages().Say(605 "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,606 symbol.name(), xType->AsFortran());607 } else {608 context.messages().Say(609 "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,610 symbol.name());611 }612 }613 return std::nullopt;614}615 616// Specification expression validation (10.1.11(2), C1010)617class CheckSpecificationExprHelper618 : public AnyTraverse<CheckSpecificationExprHelper,619 std::optional<std::string>> {620public:621 using Result = std::optional<std::string>;622 using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;623 explicit CheckSpecificationExprHelper(const semantics::Scope &s,624 FoldingContext &context, bool forElementalFunctionResult)625 : Base{*this}, scope_{s}, context_{context},626 forElementalFunctionResult_{forElementalFunctionResult} {}627 using Base::operator();628 629 Result operator()(const CoarrayRef &) const { return "coindexed reference"; }630 631 Result operator()(const semantics::Symbol &symbol) const {632 const auto &ultimate{symbol.GetUltimate()};633 const auto *object{ultimate.detailsIf<semantics::ObjectEntityDetails>()};634 bool isInitialized{semantics::IsSaved(ultimate) &&635 !IsAllocatable(ultimate) && object &&636 (ultimate.test(Symbol::Flag::InDataStmt) ||637 object->init().has_value())};638 bool hasHostAssociation{639 &symbol.owner() != &scope_ || &ultimate.owner() != &scope_};640 if (const auto *assoc{641 ultimate.detailsIf<semantics::AssocEntityDetails>()}) {642 return (*this)(assoc->expr());643 } else if (semantics::IsNamedConstant(ultimate) ||644 ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) {645 return std::nullopt;646 } else if (scope_.IsDerivedType() &&647 IsVariableName(ultimate)) { // C750, C754648 return "derived type component or type parameter value not allowed to "649 "reference variable '"s +650 ultimate.name().ToString() + "'";651 } else if (IsDummy(ultimate)) {652 if (!inInquiry_ && forElementalFunctionResult_) {653 return "dependence on value of dummy argument '"s +654 ultimate.name().ToString() + "'";655 } else if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {656 return "reference to OPTIONAL dummy argument '"s +657 ultimate.name().ToString() + "'";658 } else if (!inInquiry_ && !hasHostAssociation &&659 ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {660 return "reference to INTENT(OUT) dummy argument '"s +661 ultimate.name().ToString() + "'";662 } else if (!ultimate.has<semantics::ObjectEntityDetails>()) {663 return "dummy procedure argument";664 } else {665 // Sketchy case: some compilers allow an INTENT(OUT) dummy argument666 // to be used in a specification expression if it is host-associated.667 // The arguments raised in support this usage, however, depend on668 // a reading of the standard that would also accept an OPTIONAL669 // host-associated dummy argument, and that doesn't seem like a670 // good idea.671 if (!inInquiry_ && hasHostAssociation &&672 ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {673 context_.Warn(common::UsageWarning::HostAssociatedIntentOutInSpecExpr,674 "specification expression refers to host-associated INTENT(OUT) dummy argument '%s'"_port_en_US,675 ultimate.name());676 }677 return std::nullopt;678 }679 } else if (hasHostAssociation) {680 return std::nullopt; // host association is in play681 } else if (isInitialized &&682 context_.languageFeatures().IsEnabled(683 common::LanguageFeature::SavedLocalInSpecExpr)) {684 context_.Warn(common::LanguageFeature::SavedLocalInSpecExpr,685 "specification expression refers to local object '%s' (initialized and saved)"_port_en_US,686 ultimate.name());687 return std::nullopt;688 } else if (const auto *object{689 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {690 if (object->commonBlock()) {691 return std::nullopt;692 }693 }694 if (inInquiry_) {695 return std::nullopt;696 } else {697 return "reference to local entity '"s + ultimate.name().ToString() + "'";698 }699 }700 701 Result operator()(const Component &x) const {702 // Don't look at the component symbol.703 return (*this)(x.base());704 }705 Result operator()(const ArrayRef &x) const {706 if (auto result{(*this)(x.base())}) {707 return result;708 }709 // The subscripts don't get special protection for being in a710 // specification inquiry context;711 auto restorer{common::ScopedSet(inInquiry_, false)};712 return (*this)(x.subscript());713 }714 Result operator()(const Substring &x) const {715 if (auto result{(*this)(x.parent())}) {716 return result;717 }718 // The bounds don't get special protection for being in a719 // specification inquiry context;720 auto restorer{common::ScopedSet(inInquiry_, false)};721 if (auto result{(*this)(x.lower())}) {722 return result;723 }724 return (*this)(x.upper());725 }726 Result operator()(const DescriptorInquiry &x) const {727 // Many uses of SIZE(), LBOUND(), &c. that are valid in specification728 // expressions will have been converted to expressions over descriptor729 // inquiries by Fold().730 // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X))731 if (IsPermissibleInquiry(732 x.base().GetFirstSymbol(), x.base().GetLastSymbol(), x.field())) {733 auto restorer{common::ScopedSet(inInquiry_, true)};734 return (*this)(x.base());735 } else if (IsConstantExpr(x)) {736 return std::nullopt;737 } else {738 return "non-constant descriptor inquiry not allowed for local object";739 }740 }741 742 Result operator()(const TypeParamInquiry &inq) const {743 if (scope_.IsDerivedType()) {744 if (!IsConstantExpr(inq) &&745 inq.base() /* X%T, not local T */) { // C750, C754746 return "non-constant reference to a type parameter inquiry not allowed "747 "for derived type components or type parameter values";748 }749 } else if (inq.base() &&750 IsInquiryAlwaysPermissible(inq.base()->GetFirstSymbol())) {751 auto restorer{common::ScopedSet(inInquiry_, true)};752 return (*this)(inq.base());753 } else if (!IsConstantExpr(inq)) {754 return "non-constant type parameter inquiry not allowed for local object";755 }756 return std::nullopt;757 }758 759 Result operator()(const ProcedureRef &x) const {760 if (const auto *symbol{x.proc().GetSymbol()}) {761 const Symbol &ultimate{symbol->GetUltimate()};762 if (!semantics::IsPureProcedure(ultimate)) {763 return "reference to impure function '"s + ultimate.name().ToString() +764 "'";765 }766 if (semantics::IsStmtFunction(ultimate)) {767 return "reference to statement function '"s +768 ultimate.name().ToString() + "'";769 }770 if (scope_.IsDerivedType()) { // C750, C754771 return "reference to function '"s + ultimate.name().ToString() +772 "' not allowed for derived type components or type parameter"773 " values";774 }775 if (auto procChars{characteristics::Procedure::Characterize(776 x.proc(), context_, /*emitError=*/true)}) {777 const auto iter{std::find_if(procChars->dummyArguments.begin(),778 procChars->dummyArguments.end(),779 [](const characteristics::DummyArgument &dummy) {780 return std::holds_alternative<characteristics::DummyProcedure>(781 dummy.u);782 })};783 if (iter != procChars->dummyArguments.end() &&784 ultimate.name().ToString() != "__builtin_c_funloc") {785 return "reference to function '"s + ultimate.name().ToString() +786 "' with dummy procedure argument '" + iter->name + '\'';787 }788 }789 // References to internal functions are caught in expression semantics.790 // TODO: other checks for standard module procedures791 auto restorer{common::ScopedSet(inInquiry_, false)};792 return (*this)(x.arguments());793 } else { // intrinsic794 const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};795 bool inInquiry{context_.intrinsics().GetIntrinsicClass(intrin.name) ==796 IntrinsicClass::inquiryFunction};797 if (scope_.IsDerivedType()) { // C750, C754798 if ((context_.intrinsics().IsIntrinsic(intrin.name) &&799 badIntrinsicsForComponents_.find(intrin.name) !=800 badIntrinsicsForComponents_.end())) {801 return "reference to intrinsic '"s + intrin.name +802 "' not allowed for derived type components or type parameter"803 " values";804 }805 if (inInquiry && !IsConstantExpr(x)) {806 return "non-constant reference to inquiry intrinsic '"s +807 intrin.name +808 "' not allowed for derived type components or type"809 " parameter values";810 }811 }812 // Type-determined inquiries (DIGITS, HUGE, &c.) will have already been813 // folded and won't arrive here. Inquiries that are represented with814 // DescriptorInquiry operations (LBOUND) are checked elsewhere. If a815 // call that makes it to here satisfies the requirements of a constant816 // expression (as Fortran defines it), it's fine.817 if (IsConstantExpr(x)) {818 return std::nullopt;819 }820 if (intrin.name == "present") {821 return std::nullopt; // always ok822 }823 const auto &proc{intrin.characteristics.value()};824 std::size_t j{0};825 for (const auto &arg : x.arguments()) {826 bool checkArg{true};827 if (const auto *dataDummy{j < proc.dummyArguments.size()828 ? std::get_if<characteristics::DummyDataObject>(829 &proc.dummyArguments[j].u)830 : nullptr}) {831 if (dataDummy->attrs.test(characteristics::DummyDataObject::Attr::832 OnlyIntrinsicInquiry)) {833 checkArg = false; // value unused, e.g. IEEE_SUPPORT_FLAG(,,,. X)834 }835 }836 if (arg && checkArg) {837 // Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y838 if (inInquiry) {839 if (auto dataRef{ExtractDataRef(*arg, true, true)}) {840 if (intrin.name == "allocated" || intrin.name == "associated" ||841 intrin.name == "is_contiguous") { // ok842 } else if (intrin.name == "len" &&843 IsPermissibleInquiry(dataRef->GetFirstSymbol(),844 dataRef->GetLastSymbol(),845 DescriptorInquiry::Field::Len)) { // ok846 } else if (intrin.name == "lbound" &&847 IsPermissibleInquiry(dataRef->GetFirstSymbol(),848 dataRef->GetLastSymbol(),849 DescriptorInquiry::Field::LowerBound)) { // ok850 } else if ((intrin.name == "shape" || intrin.name == "size" ||851 intrin.name == "sizeof" ||852 intrin.name == "storage_size" ||853 intrin.name == "ubound") &&854 IsPermissibleInquiry(dataRef->GetFirstSymbol(),855 dataRef->GetLastSymbol(),856 DescriptorInquiry::Field::Extent)) { // ok857 } else {858 return "non-constant inquiry function '"s + intrin.name +859 "' not allowed for local object";860 }861 }862 }863 auto restorer{common::ScopedSet(inInquiry_, inInquiry)};864 if (auto err{(*this)(*arg)}) {865 return err;866 }867 }868 ++j;869 }870 return std::nullopt;871 }872 }873 874private:875 const semantics::Scope &scope_;876 FoldingContext &context_;877 // Contextual information: this flag is true when in an argument to878 // an inquiry intrinsic like SIZE().879 mutable bool inInquiry_{false};880 bool forElementalFunctionResult_{false}; // F'2023 C15121881 const std::set<std::string> badIntrinsicsForComponents_{882 "allocated", "associated", "extends_type_of", "present", "same_type_as"};883 884 bool IsInquiryAlwaysPermissible(const semantics::Symbol &) const;885 bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol,886 const semantics::Symbol &lastSymbol,887 DescriptorInquiry::Field field) const;888};889 890bool CheckSpecificationExprHelper::IsInquiryAlwaysPermissible(891 const semantics::Symbol &symbol) const {892 if (&symbol.owner() != &scope_ || symbol.has<semantics::UseDetails>() ||893 symbol.owner().kind() == semantics::Scope::Kind::Module ||894 semantics::FindCommonBlockContaining(symbol) ||895 symbol.has<semantics::HostAssocDetails>()) {896 return true; // it's nonlocal897 } else if (semantics::IsDummy(symbol) && !forElementalFunctionResult_) {898 return true;899 } else {900 return false;901 }902}903 904bool CheckSpecificationExprHelper::IsPermissibleInquiry(905 const semantics::Symbol &firstSymbol, const semantics::Symbol &lastSymbol,906 DescriptorInquiry::Field field) const {907 if (IsInquiryAlwaysPermissible(firstSymbol)) {908 return true;909 }910 // Inquiries on local objects may not access a deferred bound or length.911 // (This code used to be a switch, but it proved impossible to write it912 // thus without running afoul of bogus warnings from different C++913 // compilers.)914 if (field == DescriptorInquiry::Field::Rank) {915 return true; // always known916 }917 const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()};918 if (field == DescriptorInquiry::Field::LowerBound ||919 field == DescriptorInquiry::Field::Extent ||920 field == DescriptorInquiry::Field::Stride) {921 return object && !object->shape().CanBeDeferredShape();922 }923 if (field == DescriptorInquiry::Field::Len) {924 return object && object->type() &&925 object->type()->category() == semantics::DeclTypeSpec::Character &&926 !object->type()->characterTypeSpec().length().isDeferred();927 }928 return false;929}930 931template <typename A>932void CheckSpecificationExpr(const A &x, const semantics::Scope &scope,933 FoldingContext &context, bool forElementalFunctionResult) {934 CheckSpecificationExprHelper errors{935 scope, context, forElementalFunctionResult};936 if (auto why{errors(x)}) {937 context.messages().Say("Invalid specification expression%s: %s"_err_en_US,938 forElementalFunctionResult ? " for elemental function result" : "",939 *why);940 }941}942 943template void CheckSpecificationExpr(const Expr<SomeType> &,944 const semantics::Scope &, FoldingContext &,945 bool forElementalFunctionResult);946template void CheckSpecificationExpr(const Expr<SomeInteger> &,947 const semantics::Scope &, FoldingContext &,948 bool forElementalFunctionResult);949template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,950 const semantics::Scope &, FoldingContext &,951 bool forElementalFunctionResult);952template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,953 const semantics::Scope &, FoldingContext &,954 bool forElementalFunctionResult);955template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,956 const semantics::Scope &, FoldingContext &,957 bool forElementalFunctionResult);958template void CheckSpecificationExpr(959 const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,960 FoldingContext &, bool forElementalFunctionResult);961 962// IsContiguous() -- 9.5.4963class IsContiguousHelper964 : public AnyTraverse<IsContiguousHelper, std::optional<bool>> {965public:966 using Result = std::optional<bool>; // tri-state967 using Base = AnyTraverse<IsContiguousHelper, Result>;968 explicit IsContiguousHelper(FoldingContext &c,969 bool namedConstantSectionsAreContiguous,970 bool firstDimensionStride1 = false)971 : Base{*this}, context_{c},972 namedConstantSectionsAreContiguous_{namedConstantSectionsAreContiguous},973 firstDimensionStride1_{firstDimensionStride1} {}974 using Base::operator();975 976 template <typename T> Result operator()(const Constant<T> &) const {977 return true;978 }979 Result operator()(const StaticDataObject &) const { return true; }980 Result operator()(const semantics::Symbol &symbol) const {981 const auto &ultimate{symbol.GetUltimate()};982 if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) {983 return true;984 } else if (!IsVariable(symbol)) {985 return true;986 } else if (ultimate.Rank() == 0) {987 // Extension: accept scalars as a degenerate case of988 // simple contiguity to allow their use in contexts like989 // data targets in pointer assignments with remapping.990 return true;991 } else if (const auto *details{992 ultimate.detailsIf<semantics::AssocEntityDetails>()}) {993 // RANK(*) associating entity is contiguous.994 if (details->IsAssumedSize()) {995 return true;996 } else if (!IsVariable(details->expr()) &&997 (namedConstantSectionsAreContiguous_ ||998 !ExtractDataRef(details->expr(), true, true))) {999 // Selector is associated to an expression value.1000 return true;1001 } else {1002 return Base::operator()(ultimate); // use expr1003 }1004 } else if (semantics::IsPointer(ultimate) || IsAssumedShape(ultimate) ||1005 IsAssumedRank(ultimate)) {1006 return std::nullopt;1007 } else if (ultimate.has<semantics::ObjectEntityDetails>()) {1008 return true;1009 } else {1010 return Base::operator()(ultimate);1011 }1012 }1013 1014 Result operator()(const ArrayRef &x) const {1015 if (x.Rank() == 0) {1016 return true; // scalars considered contiguous1017 }1018 int subscriptRank{0};1019 auto baseLbounds{GetLBOUNDs(context_, x.base())};1020 auto baseUbounds{GetUBOUNDs(context_, x.base())};1021 auto subscripts{CheckSubscripts(1022 x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)};1023 if (!subscripts.value_or(false)) {1024 return subscripts; // subscripts not known to be contiguous1025 } else if (subscriptRank > 0) {1026 // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous.1027 return (*this)(x.base());1028 } else {1029 // a(:)%b(1,1) is (probably) not contiguous.1030 return std::nullopt;1031 }1032 }1033 Result operator()(const CoarrayRef &x) const { return (*this)(x.base()); }1034 Result operator()(const Component &x) const {1035 if (x.base().Rank() == 0) {1036 return (*this)(x.GetLastSymbol());1037 } else {1038 const DataRef &base{x.base()};1039 if (Result baseIsContiguous{(*this)(base)}) {1040 if (!*baseIsContiguous) {1041 return false;1042 } else {1043 bool sizeKnown{false};1044 if (auto constShape{GetConstantExtents(context_, x)}) {1045 sizeKnown = true;1046 if (GetSize(*constShape) <= 1) {1047 return true; // empty or singleton1048 }1049 }1050 const Symbol &last{base.GetLastSymbol()};1051 if (auto type{DynamicType::From(last)}) {1052 CHECK(type->category() == TypeCategory::Derived);1053 if (!type->IsPolymorphic()) {1054 const auto &derived{type->GetDerivedTypeSpec()};1055 if (const auto *scope{derived.scope()}) {1056 auto iter{scope->begin()};1057 if (++iter == scope->end()) {1058 return true; // type has but one component1059 } else if (sizeKnown) {1060 return false; // multiple components & array size is known > 11061 }1062 }1063 }1064 }1065 }1066 }1067 return std::nullopt;1068 }1069 }1070 Result operator()(const ComplexPart &x) const {1071 // TODO: should be true when base is empty array or singleton, too1072 return x.complex().Rank() == 0;1073 }1074 Result operator()(const Substring &x) const {1075 if (x.Rank() == 0) {1076 return true; // scalar substring always contiguous1077 }1078 // Substrings with rank must have DataRefs as their parents1079 const DataRef &parentDataRef{DEREF(x.GetParentIf<DataRef>())};1080 std::optional<std::int64_t> len;1081 if (auto lenExpr{parentDataRef.LEN()}) {1082 len = ToInt64(Fold(context_, std::move(*lenExpr)));1083 if (len) {1084 if (*len <= 0) {1085 return true; // empty substrings1086 } else if (*len == 1) {1087 // Substrings can't be incomplete; is base array contiguous?1088 return (*this)(parentDataRef);1089 }1090 }1091 }1092 std::optional<std::int64_t> upper;1093 bool upperIsLen{false};1094 if (auto upperExpr{x.upper()}) {1095 upper = ToInt64(Fold(context_, common::Clone(*upperExpr)));1096 if (upper) {1097 if (*upper < 1) {1098 return true; // substring(n:0) empty1099 }1100 upperIsLen = len && *upper >= *len;1101 } else if (const auto *inquiry{1102 UnwrapConvertedExpr<DescriptorInquiry>(*upperExpr)};1103 inquiry && inquiry->field() == DescriptorInquiry::Field::Len) {1104 upperIsLen =1105 &parentDataRef.GetLastSymbol() == &inquiry->base().GetLastSymbol();1106 }1107 } else {1108 upperIsLen = true; // substring(n:)1109 }1110 if (auto lower{ToInt64(Fold(context_, x.lower()))}) {1111 if (*lower == 1 && upperIsLen) {1112 // known complete substring; is base contiguous?1113 return (*this)(parentDataRef);1114 } else if (upper) {1115 if (*upper < *lower) {1116 return true; // empty substring(3:2)1117 } else if (*lower > 1) {1118 return false; // known incomplete substring1119 } else if (len && *upper < *len) {1120 return false; // known incomplete substring1121 }1122 }1123 }1124 return std::nullopt; // contiguity not known1125 }1126 1127 Result operator()(const ProcedureRef &x) const {1128 if (auto chars{characteristics::Procedure::Characterize(1129 x.proc(), context_, /*emitError=*/true)}) {1130 if (chars->functionResult) {1131 const auto &result{*chars->functionResult};1132 if (!result.IsProcedurePointer()) {1133 if (result.attrs.test(1134 characteristics::FunctionResult::Attr::Contiguous)) {1135 return true;1136 }1137 if (!result.attrs.test(1138 characteristics::FunctionResult::Attr::Pointer)) {1139 return true;1140 }1141 if (const auto *type{result.GetTypeAndShape()};1142 type && type->Rank() == 0) {1143 return true; // pointer to scalar1144 }1145 // Must be non-CONTIGUOUS pointer to array1146 }1147 }1148 }1149 return std::nullopt;1150 }1151 1152 Result operator()(const NullPointer &) const { return true; }1153 1154private:1155 // Returns "true" for a provably empty or simply contiguous array section;1156 // return "false" for a provably nonempty discontiguous section or for use1157 // of a vector subscript.1158 std::optional<bool> CheckSubscripts(const std::vector<Subscript> &subscript,1159 int &rank, const Shape *baseLbounds = nullptr,1160 const Shape *baseUbounds = nullptr) const {1161 bool anyTriplet{false};1162 rank = 0;1163 // Detect any provably empty dimension in this array section, which would1164 // render the whole section empty and therefore vacuously contiguous.1165 std::optional<bool> result;1166 bool mayBeEmpty{false};1167 auto dims{subscript.size()};1168 std::vector<bool> knownPartialSlice(dims, false);1169 for (auto j{dims}; j-- > 0;) {1170 if (j == 0 && firstDimensionStride1_ && !result.value_or(true)) {1171 result.reset(); // ignore problems on later dimensions1172 }1173 std::optional<ConstantSubscript> dimLbound;1174 std::optional<ConstantSubscript> dimUbound;1175 std::optional<ConstantSubscript> dimExtent;1176 if (baseLbounds && j < baseLbounds->size()) {1177 if (const auto &lb{baseLbounds->at(j)}) {1178 dimLbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*lb}));1179 }1180 }1181 if (baseUbounds && j < baseUbounds->size()) {1182 if (const auto &ub{baseUbounds->at(j)}) {1183 dimUbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*ub}));1184 }1185 }1186 if (dimLbound && dimUbound) {1187 if (*dimLbound <= *dimUbound) {1188 dimExtent = *dimUbound - *dimLbound + 1;1189 } else {1190 // This is an empty dimension.1191 result = true;1192 dimExtent = 0;1193 }1194 }1195 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {1196 ++rank;1197 const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()};1198 const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()};1199 std::optional<ConstantSubscript> lowerVal{lowerBound1200 ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound}))1201 : dimLbound};1202 std::optional<ConstantSubscript> upperVal{upperBound1203 ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*upperBound}))1204 : dimUbound};1205 if (auto stride{ToInt64(triplet->stride())}) {1206 if (j == 0 && *stride == 1 && firstDimensionStride1_) {1207 result = *stride == 1; // contiguous or empty if so1208 }1209 if (lowerVal && upperVal) {1210 if (*lowerVal < *upperVal) {1211 if (*stride < 0) {1212 result = true; // empty dimension1213 } else if (!result && *stride > 1 &&1214 *lowerVal + *stride <= *upperVal) {1215 result = false; // discontiguous if not empty1216 }1217 } else if (*lowerVal > *upperVal) {1218 if (*stride > 0) {1219 result = true; // empty dimension1220 } else if (!result && *stride < 0 &&1221 *lowerVal + *stride >= *upperVal) {1222 result = false; // discontiguous if not empty1223 }1224 } else { // bounds known and equal1225 if (j == 0 && firstDimensionStride1_) {1226 result = true; // stride doesn't matter1227 }1228 }1229 } else { // bounds not both known1230 mayBeEmpty = true;1231 }1232 } else { // stride not known1233 if (lowerVal && upperVal && *lowerVal == *upperVal) {1234 // stride doesn't matter when bounds are equal1235 if (j == 0 && firstDimensionStride1_) {1236 result = true;1237 }1238 } else {1239 mayBeEmpty = true;1240 }1241 }1242 } else if (subscript[j].Rank() > 0) { // vector subscript1243 ++rank;1244 if (!result) {1245 result = false;1246 }1247 mayBeEmpty = true;1248 } else { // scalar subscript1249 if (dimExtent && *dimExtent > 1) {1250 knownPartialSlice[j] = true;1251 }1252 }1253 }1254 if (rank == 0) {1255 result = true; // scalar1256 }1257 if (result) {1258 return result;1259 }1260 // Not provably contiguous or discontiguous at this point.1261 // Return "true" if simply contiguous, otherwise nullopt.1262 for (auto j{subscript.size()}; j-- > 0;) {1263 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {1264 auto stride{ToInt64(triplet->stride())};1265 if (!stride || stride != 1) {1266 return std::nullopt;1267 } else if (anyTriplet) {1268 if (triplet->GetLower() || triplet->GetUpper()) {1269 // all triplets before the last one must be just ":" for1270 // simple contiguity1271 return std::nullopt;1272 }1273 } else {1274 anyTriplet = true;1275 }1276 ++rank;1277 } else if (anyTriplet) {1278 // If the section cannot be empty, and this dimension's1279 // scalar subscript is known not to cover the whole1280 // dimension, then the array section is provably1281 // discontiguous.1282 return (mayBeEmpty || !knownPartialSlice[j])1283 ? std::nullopt1284 : std::make_optional(false);1285 }1286 }1287 return true; // simply contiguous1288 }1289 1290 FoldingContext &context_;1291 bool namedConstantSectionsAreContiguous_{false};1292 bool firstDimensionStride1_{false};1293};1294 1295template <typename A>1296std::optional<bool> IsContiguous(const A &x, FoldingContext &context,1297 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1) {1298 if (!IsVariable(x) &&1299 (namedConstantSectionsAreContiguous || !ExtractDataRef(x, true, true))) {1300 return true;1301 } else {1302 return IsContiguousHelper{1303 context, namedConstantSectionsAreContiguous, firstDimensionStride1}(x);1304 }1305}1306 1307std::optional<bool> IsContiguous(const ActualArgument &actual,1308 FoldingContext &fc, bool namedConstantSectionsAreContiguous,1309 bool firstDimensionStride1) {1310 if (auto *expr{actual.UnwrapExpr()}) {1311 return IsContiguous(1312 *expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1);1313 } else {1314 return std::nullopt;1315 }1316}1317 1318template std::optional<bool> IsContiguous(const Expr<SomeType> &,1319 FoldingContext &, bool namedConstantSectionsAreContiguous,1320 bool firstDimensionStride1);1321template std::optional<bool> IsContiguous(const ActualArgument &,1322 FoldingContext &, bool namedConstantSectionsAreContiguous,1323 bool firstDimensionStride1);1324template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &,1325 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);1326template std::optional<bool> IsContiguous(const Substring &, FoldingContext &,1327 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);1328template std::optional<bool> IsContiguous(const Component &, FoldingContext &,1329 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);1330template std::optional<bool> IsContiguous(const ComplexPart &, FoldingContext &,1331 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);1332template std::optional<bool> IsContiguous(const CoarrayRef &, FoldingContext &,1333 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);1334template std::optional<bool> IsContiguous(const Symbol &, FoldingContext &,1335 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);1336 1337// IsErrorExpr()1338struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {1339 using Result = bool;1340 using Base = AnyTraverse<IsErrorExprHelper, Result>;1341 IsErrorExprHelper() : Base{*this} {}1342 using Base::operator();1343 1344 bool operator()(const SpecificIntrinsic &x) {1345 return x.name == IntrinsicProcTable::InvalidName;1346 }1347};1348 1349template <typename A> bool IsErrorExpr(const A &x) {1350 return IsErrorExprHelper{}(x);1351}1352 1353template bool IsErrorExpr(const Expr<SomeType> &);1354 1355// C15771356// TODO: Also check C1579 & C1582 here1357class StmtFunctionChecker1358 : public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> {1359public:1360 using Result = std::optional<parser::Message>;1361 using Base = AnyTraverse<StmtFunctionChecker, Result>;1362 1363 static constexpr auto feature{1364 common::LanguageFeature::StatementFunctionExtensions};1365 1366 StmtFunctionChecker(const Symbol &sf, FoldingContext &context)1367 : Base{*this}, sf_{sf}, context_{context} {1368 if (!context_.languageFeatures().IsEnabled(feature)) {1369 severity_ = parser::Severity::Error;1370 } else if (context_.languageFeatures().ShouldWarn(feature)) {1371 severity_ = parser::Severity::Portability;1372 }1373 }1374 using Base::operator();1375 1376 Result Return(parser::Message &&msg) const {1377 if (severity_) {1378 msg.set_severity(*severity_);1379 if (*severity_ != parser::Severity::Error) {1380 msg.set_languageFeature(feature);1381 }1382 }1383 return std::move(msg);1384 }1385 1386 template <typename T> Result operator()(const ArrayConstructor<T> &) const {1387 if (severity_) {1388 return Return(parser::Message{sf_.name(),1389 "Statement function '%s' should not contain an array constructor"_port_en_US,1390 sf_.name()});1391 } else {1392 return std::nullopt;1393 }1394 }1395 Result operator()(const StructureConstructor &) const {1396 if (severity_) {1397 return Return(parser::Message{sf_.name(),1398 "Statement function '%s' should not contain a structure constructor"_port_en_US,1399 sf_.name()});1400 } else {1401 return std::nullopt;1402 }1403 }1404 Result operator()(const TypeParamInquiry &) const {1405 if (severity_) {1406 return Return(parser::Message{sf_.name(),1407 "Statement function '%s' should not contain a type parameter inquiry"_port_en_US,1408 sf_.name()});1409 } else {1410 return std::nullopt;1411 }1412 }1413 Result operator()(const ProcedureDesignator &proc) const {1414 if (const Symbol * symbol{proc.GetSymbol()}) {1415 const Symbol &ultimate{symbol->GetUltimate()};1416 if (const auto *subp{1417 ultimate.detailsIf<semantics::SubprogramDetails>()}) {1418 if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) {1419 if (ultimate.name().begin() > sf_.name().begin()) {1420 return parser::Message{sf_.name(),1421 "Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US,1422 sf_.name(), ultimate.name()};1423 }1424 }1425 }1426 if (auto chars{characteristics::Procedure::Characterize(1427 proc, context_, /*emitError=*/true)}) {1428 if (!chars->CanBeCalledViaImplicitInterface()) {1429 if (severity_) {1430 return Return(parser::Message{sf_.name(),1431 "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US,1432 sf_.name(), symbol->name()});1433 }1434 }1435 }1436 }1437 if (proc.Rank() > 0) {1438 if (severity_) {1439 return Return(parser::Message{sf_.name(),1440 "Statement function '%s' should not reference a function that returns an array"_port_en_US,1441 sf_.name()});1442 }1443 }1444 return std::nullopt;1445 }1446 Result operator()(const ActualArgument &arg) const {1447 if (const auto *expr{arg.UnwrapExpr()}) {1448 if (auto result{(*this)(*expr)}) {1449 return result;1450 }1451 if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {1452 if (severity_) {1453 return Return(parser::Message{sf_.name(),1454 "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US,1455 sf_.name()});1456 }1457 }1458 }1459 return std::nullopt;1460 }1461 1462private:1463 const Symbol &sf_;1464 FoldingContext &context_;1465 std::optional<parser::Severity> severity_;1466};1467 1468std::optional<parser::Message> CheckStatementFunction(1469 const Symbol &sf, const Expr<SomeType> &expr, FoldingContext &context) {1470 return StmtFunctionChecker{sf, context}(expr);1471}1472 1473// Helper class for checking differences between actual and dummy arguments1474class CopyInOutExplicitInterface {1475public:1476 explicit CopyInOutExplicitInterface(FoldingContext &fc,1477 const ActualArgument &actual,1478 const characteristics::DummyDataObject &dummyObj)1479 : fc_{fc}, actual_{actual}, dummyObj_{dummyObj} {}1480 1481 // Returns true if dummy arg needs to be contiguous1482 bool DummyNeedsContiguity() const {1483 if (dummyObj_.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {1484 return false;1485 }1486 bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)};1487 bool dummyIsExplicitShape{dummyObj_.type.IsExplicitShape()};1488 bool dummyIsAssumedSize{dummyObj_.type.attrs().test(1489 characteristics::TypeAndShape::Attr::AssumedSize)};1490 bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()};1491 // type(*) with IGNORE_TKR(tkr) is often used to interface with C "void*".1492 // Since the other languages don't know about Fortran's discontiguity1493 // handling, such cases should require contiguity.1494 bool dummyIsVoidStar{dummyObj_.type.type().IsAssumedType() &&1495 dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type) &&1496 dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank) &&1497 dummyObj_.ignoreTKR.test(common::IgnoreTKR::Kind)};1498 // Explicit shape and assumed size arrays must be contiguous1499 bool dummyNeedsContiguity{dummyIsExplicitShape || dummyIsAssumedSize ||1500 (dummyTreatAsArray && !dummyIsPolymorphic) || dummyIsVoidStar ||1501 dummyObj_.attrs.test(1502 characteristics::DummyDataObject::Attr::Contiguous)};1503 return dummyNeedsContiguity;1504 }1505 1506 bool HavePolymorphicDifferences() const {1507 if (dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) {1508 return false;1509 }1510 if (auto actualType{1511 characteristics::TypeAndShape::Characterize(actual_, fc_)}) {1512 bool actualIsPolymorphic{actualType->type().IsPolymorphic()};1513 bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()};1514 if (actualIsPolymorphic && !dummyIsPolymorphic) {1515 return true;1516 }1517 }1518 return false;1519 }1520 1521 bool HaveArrayOrAssumedRankArgs() const {1522 bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)};1523 return IsArrayOrAssumedRank(actual_) &&1524 (IsArrayOrAssumedRank(dummyObj_) || dummyTreatAsArray);1525 }1526 1527 bool PassByValue() const {1528 return dummyObj_.attrs.test(characteristics::DummyDataObject::Attr::Value);1529 }1530 1531 bool HaveCoarrayDifferences() const {1532 return ExtractCoarrayRef(actual_) && dummyObj_.type.corank() == 0;1533 }1534 1535 bool HasIntentOut() const { return dummyObj_.intent == common::Intent::Out; }1536 1537 bool HasIntentIn() const { return dummyObj_.intent == common::Intent::In; }1538 1539 static bool IsArrayOrAssumedRank(const ActualArgument &actual) {1540 return semantics::IsAssumedRank(actual) || actual.Rank() > 0;1541 }1542 1543 static bool IsArrayOrAssumedRank(1544 const characteristics::DummyDataObject &dummy) {1545 return dummy.type.attrs().test(1546 characteristics::TypeAndShape::Attr::AssumedRank) ||1547 dummy.type.Rank() > 0;1548 }1549 1550private:1551 FoldingContext &fc_;1552 const ActualArgument &actual_;1553 const characteristics::DummyDataObject &dummyObj_;1554};1555 1556// If forCopyOut is false, returns if a particular actual/dummy argument1557// combination may need a temporary creation with copy-in operation. If1558// forCopyOut is true, returns the same for copy-out operation. For1559// procedures with explicit interface, it's expected that "dummy" is not null.1560// For procedures with implicit interface dummy may be null.1561//1562// Returns std::optional<bool> indicating whether the copy is known to be1563// needed (true) or not needed (false); returns std::nullopt if the necessity1564// of the copy is undetermined.1565//1566// Note that these copy-in and copy-out checks are done from the caller's1567// perspective, meaning that for copy-in the caller need to do the copy1568// before calling the callee. Similarly, for copy-out the caller is expected1569// to do the copy after the callee returns.1570std::optional<bool> ActualArgNeedsCopy(const ActualArgument *actual,1571 const characteristics::DummyArgument *dummy, FoldingContext &fc,1572 bool forCopyOut) {1573 if (!actual) {1574 return std::nullopt;1575 }1576 if (actual->isAlternateReturn()) {1577 return std::nullopt;1578 }1579 const auto *dummyObj{dummy1580 ? std::get_if<characteristics::DummyDataObject>(&dummy->u)1581 : nullptr};1582 const bool forCopyIn{!forCopyOut};1583 if (!evaluate::IsVariable(*actual)) {1584 // Expressions are copy-in, but not copy-out.1585 return forCopyIn;1586 }1587 auto maybeContigActual{IsContiguous(*actual, fc)};1588 if (dummyObj) { // Explict interface1589 CopyInOutExplicitInterface check{fc, *actual, *dummyObj};1590 if (forCopyOut && check.HasIntentIn()) {1591 // INTENT(IN) dummy args never need copy-out1592 return false;1593 }1594 if (forCopyIn && check.HasIntentOut()) {1595 // INTENT(OUT) dummy args never need copy-in1596 return false;1597 }1598 if (check.PassByValue()) {1599 // Pass by value, always copy-in, never copy-out1600 return forCopyIn;1601 }1602 if (check.HaveCoarrayDifferences()) {1603 return true;1604 }1605 // Note: contiguity and polymorphic checks deal with array or assumed rank1606 // arguments1607 if (!check.HaveArrayOrAssumedRankArgs()) {1608 return false;1609 }1610 if (maybeContigActual.has_value()) {1611 // We know whether actual arg is contiguous or not1612 bool isContiguousActual{maybeContigActual.value()};1613 bool actualArgNeedsCopy{1614 (!isContiguousActual || check.HavePolymorphicDifferences()) &&1615 check.DummyNeedsContiguity()};1616 return actualArgNeedsCopy;1617 } else {1618 // We don't know whether actual arg is contiguous or not1619 return check.DummyNeedsContiguity();1620 }1621 } else { // Implicit interface1622 if (maybeContigActual.has_value()) {1623 // If known contiguous, don't copy in/out.1624 // If known non-contiguous, copy in/out.1625 return !*maybeContigActual;1626 }1627 }1628 return std::nullopt;1629}1630 1631} // namespace Fortran::evaluate1632