From c37da6820a94ce63e1f9c8f44063bb4997f4f69e Mon Sep 17 00:00:00 2001 From: Sarka Holendova Date: Fri, 19 Sep 2025 13:04:59 +0200 Subject: [PATCH 1/2] [Flang] Fix SIMPLE attribute logic and formatting per review - Removed `|| proc.IsSimple()` from the `if (proc.IsPure())` condition in check-expression.cpp. - Removed `Attr::Simple` from the isPureProcedureImpl helper in tools.cpp. - Fixed formatting issues. --- flang/include/flang/Evaluate/call.h | 3 +- .../include/flang/Evaluate/characteristics.h | 7 +- flang/include/flang/Evaluate/tools.h | 12 +- flang/include/flang/Parser/dump-parse-tree.h | 1 + flang/include/flang/Parser/parse-tree.h | 5 +- flang/include/flang/Semantics/attr.h | 2 +- flang/lib/Evaluate/call.cpp | 30 +- flang/lib/Evaluate/check-expression.cpp | 1635 ----------------- flang/lib/Evaluate/tools.cpp | 53 +- flang/lib/Parser/program-parsers.cpp | 3 +- flang/lib/Parser/unparse.cpp | 1 + flang/lib/Semantics/resolve-names.cpp | 96 +- flang/test/Parser/simple-unparse.f90 | 13 + flang/test/Parser/simple.f90 | 10 + 14 files changed, 148 insertions(+), 1723 deletions(-) delete mode 100644 flang/lib/Evaluate/check-expression.cpp create mode 100644 flang/test/Parser/simple-unparse.f90 create mode 100644 flang/test/Parser/simple.f90 diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h index 2a5929b873d74..30505a89d16cd 100644 --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -99,7 +99,7 @@ class ActualArgument { } const Symbol *GetAssumedTypeDummy() const { - if (const AssumedType * aType{std::get_if(&u_)}) { + if (const AssumedType *aType{std::get_if(&u_)}) { return &aType->symbol(); } else { return nullptr; @@ -219,6 +219,7 @@ struct ProcedureDesignator { int Rank() const; bool IsElemental() const; bool IsPure() const; + bool IsSimple() const; std::optional> LEN() const; llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const; diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index b6a9ebefec9df..7d094fa2236fb 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -363,10 +363,10 @@ struct FunctionResult { // 15.3.1 struct Procedure { - ENUM_CLASS(Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer, - NullAllocatable, Subroutine) + ENUM_CLASS(Attr, Pure, Simple, Elemental, BindC, ImplicitInterface, + NullPointer, NullAllocatable, Subroutine) using Attrs = common::EnumSet; - Procedure(){}; + Procedure() {}; Procedure(FunctionResult &&, DummyArguments &&, Attrs); Procedure(DummyArguments &&, Attrs); // for subroutines and NULL() DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure) @@ -396,6 +396,7 @@ struct Procedure { bool IsSubroutine() const { return attrs.test(Attr::Subroutine); } bool IsPure() const { return attrs.test(Attr::Pure); } + bool IsSimple() const { return attrs.test(Attr::Simple); } bool IsElemental() const { return attrs.test(Attr::Elemental); } bool IsBindC() const { return attrs.test(Attr::BindC); } bool HasExplicitInterface() const { diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index 5f2f199e778c7..4300dfb27c37f 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -380,7 +380,7 @@ const Symbol *IsArrayElement(const Expr &expr, bool intoSubstring = true, bool skipComponents = false) { if (auto dataRef{ExtractDataRef(expr, intoSubstring)}) { for (const DataRef *ref{&*dataRef}; ref;) { - if (const Component * component{std::get_if(&ref->u)}) { + if (const Component *component{std::get_if(&ref->u)}) { ref = skipComponents ? &component->base() : nullptr; } else if (const auto *coarrayRef{std::get_if(&ref->u)}) { ref = &coarrayRef->base(); @@ -436,7 +436,7 @@ struct ExtractCoindexedObjectHelper { return common::visit(*this, dataRef.u); } std::optional operator()(const NamedEntity &named) const { - if (const Component * component{named.UnwrapComponent()}) { + if (const Component *component{named.UnwrapComponent()}) { return (*this)(*component); } else { return std::nullopt; @@ -969,7 +969,7 @@ template const Symbol *GetLastSymbol(const A &x) { // its set of attributes, otherwise the empty set. Also works on variables that // are pointer results of functions. template semantics::Attrs GetAttrs(const A &x) { - if (const Symbol * symbol{GetLastSymbol(x)}) { + if (const Symbol *symbol{GetLastSymbol(x)}) { return symbol->attrs(); } else { return {}; @@ -980,7 +980,7 @@ template <> inline semantics::Attrs GetAttrs>(const Expr &x) { if (IsVariable(x)) { if (const auto *procRef{UnwrapProcedureRef(x)}) { - if (const Symbol * interface{procRef->proc().GetInterfaceSymbol()}) { + if (const Symbol *interface{procRef->proc().GetInterfaceSymbol()}) { if (const auto *details{ interface->detailsIf()}) { if (details->isFunction() && @@ -992,7 +992,7 @@ inline semantics::Attrs GetAttrs>(const Expr &x) { } } } - if (const Symbol * symbol{GetLastSymbol(x)}) { + if (const Symbol *symbol{GetLastSymbol(x)}) { return symbol->attrs(); } else { return {}; @@ -1543,6 +1543,8 @@ inline bool IsAlternateEntry(const Symbol *symbol) { bool IsVariableName(const Symbol &); bool IsPureProcedure(const Symbol &); bool IsPureProcedure(const Scope &); +bool IsSimpleProcedure(const Symbol &); +bool IsSimpleProcedure(const Scope &); bool IsExplicitlyImpureProcedure(const Symbol &); bool IsElementalProcedure(const Symbol &); bool IsFunction(const Symbol &); diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h index 1c9fd7673e06d..73c9803df97a7 100644 --- a/flang/include/flang/Parser/dump-parse-tree.h +++ b/flang/include/flang/Parser/dump-parse-tree.h @@ -769,6 +769,7 @@ class ParseTreeDumper { NODE(PrefixSpec, Non_Recursive) NODE(PrefixSpec, Pure) NODE(PrefixSpec, Recursive) + NODE(PrefixSpec, Simple) NODE(PrefixSpec, Attributes) NODE(PrefixSpec, Launch_Bounds) NODE(PrefixSpec, Cluster_Dims) diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index 951c96b974141..57222f2c3d4f0 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -3110,7 +3110,7 @@ struct ProcedureDeclarationStmt { // R1527 prefix-spec -> // declaration-type-spec | ELEMENTAL | IMPURE | MODULE | -// NON_RECURSIVE | PURE | RECURSIVE | +// NON_RECURSIVE | PURE | SIMPLE | RECURSIVE | // (CUDA) ATTRIBUTES ( (DEVICE | GLOBAL | GRID_GLOBAL | HOST)... ) // LAUNCH_BOUNDS(expr-list) | CLUSTER_DIMS(expr-list) struct PrefixSpec { @@ -3121,11 +3121,12 @@ struct PrefixSpec { EMPTY_CLASS(Non_Recursive); EMPTY_CLASS(Pure); EMPTY_CLASS(Recursive); + EMPTY_CLASS(Simple); WRAPPER_CLASS(Attributes, std::list); WRAPPER_CLASS(Launch_Bounds, std::list); WRAPPER_CLASS(Cluster_Dims, std::list); std::variant + Pure, Recursive, Simple, Attributes, Launch_Bounds, Cluster_Dims> u; }; diff --git a/flang/include/flang/Semantics/attr.h b/flang/include/flang/Semantics/attr.h index 76fab5e0c904d..488f325de5887 100644 --- a/flang/include/flang/Semantics/attr.h +++ b/flang/include/flang/Semantics/attr.h @@ -25,7 +25,7 @@ ENUM_CLASS(Attr, ABSTRACT, ALLOCATABLE, ASYNCHRONOUS, BIND_C, CONTIGUOUS, DEFERRED, ELEMENTAL, EXTENDS, EXTERNAL, IMPURE, INTENT_IN, INTENT_INOUT, INTENT_OUT, INTRINSIC, MODULE, NON_OVERRIDABLE, NON_RECURSIVE, NOPASS, OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PUBLIC, PURE, - RECURSIVE, SAVE, TARGET, VALUE, VOLATILE) + RECURSIVE, SAVE, SIMPLE, TARGET, VALUE, VOLATILE) // Set of attributes class Attrs : public common::EnumSet { diff --git a/flang/lib/Evaluate/call.cpp b/flang/lib/Evaluate/call.cpp index f77df92a7597a..56db7730d8608 100644 --- a/flang/lib/Evaluate/call.cpp +++ b/flang/lib/Evaluate/call.cpp @@ -66,8 +66,8 @@ void ActualArgument::Parenthesize() { SpecificIntrinsic::SpecificIntrinsic( IntrinsicProcedure n, characteristics::Procedure &&chars) - : name{n}, characteristics{ - new characteristics::Procedure{std::move(chars)}} {} + : name{n}, + characteristics{new characteristics::Procedure{std::move(chars)}} {} DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic) @@ -98,7 +98,7 @@ std::optional ProcedureDesignator::GetType() const { } int ProcedureDesignator::Rank() const { - if (const Symbol * symbol{GetSymbol()}) { + if (const Symbol *symbol{GetSymbol()}) { // Subtle: will be zero for functions returning procedure pointers return symbol->Rank(); } @@ -116,7 +116,7 @@ int ProcedureDesignator::Rank() const { } const Symbol *ProcedureDesignator::GetInterfaceSymbol() const { - if (const Symbol * symbol{GetSymbol()}) { + if (const Symbol *symbol{GetSymbol()}) { const Symbol &ultimate{symbol->GetUltimate()}; if (const auto *proc{ultimate.detailsIf()}) { return proc->procInterface(); @@ -131,9 +131,9 @@ const Symbol *ProcedureDesignator::GetInterfaceSymbol() const { } bool ProcedureDesignator::IsElemental() const { - if (const Symbol * interface{GetInterfaceSymbol()}) { + if (const Symbol *interface{GetInterfaceSymbol()}) { return IsElementalProcedure(*interface); - } else if (const Symbol * symbol{GetSymbol()}) { + } else if (const Symbol *symbol{GetSymbol()}) { return IsElementalProcedure(*symbol); } else if (const auto *intrinsic{std::get_if(&u)}) { return intrinsic->characteristics.value().attrs.test( @@ -145,9 +145,9 @@ bool ProcedureDesignator::IsElemental() const { } bool ProcedureDesignator::IsPure() const { - if (const Symbol * interface{GetInterfaceSymbol()}) { + if (const Symbol *interface{GetInterfaceSymbol()}) { return IsPureProcedure(*interface); - } else if (const Symbol * symbol{GetSymbol()}) { + } else if (const Symbol *symbol{GetSymbol()}) { return IsPureProcedure(*symbol); } else if (const auto *intrinsic{std::get_if(&u)}) { return intrinsic->characteristics.value().attrs.test( @@ -158,6 +158,20 @@ bool ProcedureDesignator::IsPure() const { return false; } +bool ProcedureDesignator::IsSimple() const { + if (const Symbol *interface{GetInterfaceSymbol()}) { + return IsSimpleProcedure(*interface); + } else if (const Symbol *symbol{GetSymbol()}) { + return IsSimpleProcedure(*symbol); + } else if (const auto *intrinsic{std::get_if(&u)}) { + return intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::Simple); + } else { + DIE("ProcedureDesignator::IsSimple(): no case"); + } + return false; +} + const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const { return std::get_if(&u); } diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp deleted file mode 100644 index 8931cbe485ac2..0000000000000 --- a/flang/lib/Evaluate/check-expression.cpp +++ /dev/null @@ -1,1635 +0,0 @@ -//===-- lib/Evaluate/check-expression.cpp ---------------------------------===// -// -// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -// See https://llvm.org/LICENSE.txt for license information. -// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -// -//===----------------------------------------------------------------------===// - -#include "flang/Evaluate/check-expression.h" -#include "flang/Evaluate/characteristics.h" -#include "flang/Evaluate/intrinsics.h" -#include "flang/Evaluate/tools.h" -#include "flang/Evaluate/traverse.h" -#include "flang/Evaluate/type.h" -#include "flang/Semantics/semantics.h" -#include "flang/Semantics/symbol.h" -#include "flang/Semantics/tools.h" -#include -#include - -namespace Fortran::evaluate { - -// Constant expression predicates IsConstantExpr() & IsScopeInvariantExpr(). -// This code determines whether an expression is a "constant expression" -// in the sense of section 10.1.12. This is not the same thing as being -// able to fold it (yet) into a known constant value; specifically, -// the expression may reference derived type kind parameters whose values -// are not yet known. -// -// The variant form (IsScopeInvariantExpr()) also accepts symbols that are -// INTENT(IN) dummy arguments without the VALUE attribute. -template -class IsConstantExprHelper - : public AllTraverse, true> { -public: - using Base = AllTraverse; - IsConstantExprHelper() : Base{*this} {} - using Base::operator(); - - // A missing expression is not considered to be constant. - template bool operator()(const std::optional &x) const { - return x && (*this)(*x); - } - - bool operator()(const TypeParamInquiry &inq) const { - return INVARIANT || semantics::IsKindTypeParameter(inq.parameter()); - } - bool operator()(const semantics::Symbol &symbol) const { - const auto &ultimate{GetAssociationRoot(symbol)}; - return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) || - IsInitialProcedureTarget(ultimate) || - ultimate.has() || - (INVARIANT && IsIntentIn(symbol) && !IsOptional(symbol) && - !symbol.attrs().test(semantics::Attr::VALUE)); - } - bool operator()(const CoarrayRef &) const { return false; } - bool operator()(const semantics::ParamValue ¶m) const { - return param.isExplicit() && (*this)(param.GetExplicit()); - } - bool operator()(const ProcedureRef &) const; - bool operator()(const StructureConstructor &constructor) const { - for (const auto &[symRef, expr] : constructor) { - if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) { - return false; - } - } - return true; - } - bool operator()(const Component &component) const { - return (*this)(component.base()); - } - // Prevent integer division by known zeroes in constant expressions. - template - bool operator()( - const Divide> &division) const { - using T = Type; - if ((*this)(division.left()) && (*this)(division.right())) { - const auto divisor{GetScalarConstantValue(division.right())}; - return !divisor || !divisor->IsZero(); - } else { - return false; - } - } - - bool operator()(const Constant &) const { return true; } - bool operator()(const DescriptorInquiry &x) const { - const Symbol &sym{x.base().GetLastSymbol()}; - return INVARIANT && !IsAllocatable(sym) && - (!IsDummy(sym) || - (IsIntentIn(sym) && !IsOptional(sym) && - !sym.attrs().test(semantics::Attr::VALUE))); - } - -private: - bool IsConstantStructureConstructorComponent( - const Symbol &, const Expr &) const; - bool IsConstantExprShape(const Shape &) const; -}; - -template -bool IsConstantExprHelper::IsConstantStructureConstructorComponent( - const Symbol &component, const Expr &expr) const { - if (IsAllocatable(component)) { - return IsNullObjectPointer(&expr); - } else if (IsPointer(component)) { - return IsNullPointerOrAllocatable(&expr) || IsInitialDataTarget(expr) || - IsInitialProcedureTarget(expr); - } else { - return (*this)(expr); - } -} - -template -bool IsConstantExprHelper::operator()( - const ProcedureRef &call) const { - // LBOUND, UBOUND, and SIZE with truly constant DIM= arguments will have - // been rewritten into DescriptorInquiry operations. - if (const auto *intrinsic{std::get_if(&call.proc().u)}) { - const characteristics::Procedure &proc{intrinsic->characteristics.value()}; - if (intrinsic->name == "kind" || - intrinsic->name == IntrinsicProcTable::InvalidName || - call.arguments().empty() || !call.arguments()[0]) { - // kind is always a constant, and we avoid cascading errors by considering - // invalid calls to intrinsics to be constant - return true; - } else if (intrinsic->name == "lbound") { - auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())}; - return base && IsConstantExprShape(GetLBOUNDs(*base)); - } else if (intrinsic->name == "ubound") { - auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())}; - return base && IsConstantExprShape(GetUBOUNDs(*base)); - } else if (intrinsic->name == "shape" || intrinsic->name == "size") { - auto shape{GetShape(call.arguments()[0]->UnwrapExpr())}; - return shape && IsConstantExprShape(*shape); - } else if (proc.IsPure()) { - std::size_t j{0}; - for (const auto &arg : call.arguments()) { - if (const auto *dataDummy{j < proc.dummyArguments.size() - ? std::get_if( - &proc.dummyArguments[j].u) - : nullptr}; - dataDummy && - dataDummy->attrs.test( - characteristics::DummyDataObject::Attr::OnlyIntrinsicInquiry)) { - // The value of the argument doesn't matter - } else if (!arg) { - return false; - } else if (const auto *expr{arg->UnwrapExpr()}; - !expr || !(*this)(*expr)) { - return false; - } - ++j; - } - return true; - } - // TODO: STORAGE_SIZE - } - return false; -} - -template -bool IsConstantExprHelper::IsConstantExprShape( - const Shape &shape) const { - for (const auto &extent : shape) { - if (!(*this)(extent)) { - return false; - } - } - return true; -} - -template bool IsConstantExpr(const A &x) { - return IsConstantExprHelper{}(x); -} -template bool IsConstantExpr(const Expr &); -template bool IsConstantExpr(const Expr &); -template bool IsConstantExpr(const Expr &); -template bool IsConstantExpr(const StructureConstructor &); - -// IsScopeInvariantExpr() -template bool IsScopeInvariantExpr(const A &x) { - return IsConstantExprHelper{}(x); -} -template bool IsScopeInvariantExpr(const Expr &); -template bool IsScopeInvariantExpr(const Expr &); -template bool IsScopeInvariantExpr(const Expr &); - -// IsActuallyConstant() -struct IsActuallyConstantHelper { - template bool operator()(const A &) { return false; } - template bool operator()(const Constant &) { return true; } - template bool operator()(const Parentheses &x) { - return (*this)(x.left()); - } - template bool operator()(const Expr &x) { - return common::visit([=](const auto &y) { return (*this)(y); }, x.u); - } - bool operator()(const Expr &x) { - return common::visit([this](const auto &y) { return (*this)(y); }, x.u); - } - bool operator()(const StructureConstructor &x) { - for (const auto &pair : x) { - const Expr &y{pair.second.value()}; - const auto sym{pair.first}; - const bool compIsConstant{(*this)(y)}; - // If an allocatable component is initialized by a constant, - // the structure constructor is not a constant. - if ((!compIsConstant && !IsNullPointerOrAllocatable(&y)) || - (compIsConstant && IsAllocatable(sym))) { - return false; - } - } - return true; - } - template bool operator()(const A *x) { return x && (*this)(*x); } - template bool operator()(const std::optional &x) { - return x && (*this)(*x); - } -}; - -template bool IsActuallyConstant(const A &x) { - return IsActuallyConstantHelper{}(x); -} - -template bool IsActuallyConstant(const Expr &); -template bool IsActuallyConstant(const Expr &); -template bool IsActuallyConstant(const Expr &); -template bool IsActuallyConstant(const std::optional> &); - -// Object pointer initialization checking predicate IsInitialDataTarget(). -// This code determines whether an expression is allowable as the static -// data address used to initialize a pointer with "=> x". See C765. -class IsInitialDataTargetHelper - : public AllTraverse { -public: - using Base = AllTraverse; - using Base::operator(); - explicit IsInitialDataTargetHelper(parser::ContextualMessages *m) - : Base{*this}, messages_{m} {} - - bool emittedMessage() const { return emittedMessage_; } - - bool operator()(const BOZLiteralConstant &) const { return false; } - bool operator()(const NullPointer &) const { return true; } - template bool operator()(const Constant &) const { - return false; - } - bool operator()(const semantics::Symbol &symbol) { - // This function checks only base symbols, not components. - const Symbol &ultimate{symbol.GetUltimate()}; - if (const auto *assoc{ - ultimate.detailsIf()}) { - if (const auto &expr{assoc->expr()}) { - if (IsVariable(*expr)) { - return (*this)(*expr); - } else if (messages_) { - messages_->Say( - "An initial data target may not be an associated expression ('%s')"_err_en_US, - ultimate.name()); - emittedMessage_ = true; - } - } - return false; - } else if (!CheckVarOrComponent(ultimate)) { - return false; - } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) { - if (messages_) { - messages_->Say( - "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US, - ultimate.name()); - emittedMessage_ = true; - } - return false; - } else if (!IsSaved(ultimate)) { - if (messages_) { - messages_->Say( - "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US, - ultimate.name()); - emittedMessage_ = true; - } - return false; - } else { - return true; - } - } - bool operator()(const StaticDataObject &) const { return false; } - bool operator()(const TypeParamInquiry &) const { return false; } - bool operator()(const Triplet &x) const { - return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) && - IsConstantExpr(x.stride()); - } - bool operator()(const Subscript &x) const { - return common::visit(common::visitors{ - [&](const Triplet &t) { return (*this)(t); }, - [&](const auto &y) { - return y.value().Rank() == 0 && - IsConstantExpr(y.value()); - }, - }, - x.u); - } - bool operator()(const CoarrayRef &) const { return false; } - bool operator()(const Component &x) { - return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base()); - } - bool operator()(const Substring &x) const { - return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) && - (*this)(x.parent()); - } - bool operator()(const DescriptorInquiry &) const { return false; } - template bool operator()(const ArrayConstructor &) const { - return false; - } - bool operator()(const StructureConstructor &) const { return false; } - template - bool operator()(const Operation &) const { - return false; - } - template bool operator()(const Parentheses &x) const { - return (*this)(x.left()); - } - bool operator()(const ProcedureRef &x) const { - if (const SpecificIntrinsic * intrinsic{x.proc().GetSpecificIntrinsic()}) { - return intrinsic->characteristics.value().attrs.test( - characteristics::Procedure::Attr::NullPointer) || - intrinsic->characteristics.value().attrs.test( - characteristics::Procedure::Attr::NullAllocatable); - } - return false; - } - bool operator()(const Relational &) const { return false; } - -private: - bool CheckVarOrComponent(const semantics::Symbol &symbol) { - const Symbol &ultimate{symbol.GetUltimate()}; - const char *unacceptable{nullptr}; - if (ultimate.Corank() > 0) { - unacceptable = "a coarray"; - } else if (IsAllocatable(ultimate)) { - unacceptable = "an ALLOCATABLE"; - } else if (IsPointer(ultimate)) { - unacceptable = "a POINTER"; - } else { - return true; - } - if (messages_) { - messages_->Say( - "An initial data target may not be a reference to %s '%s'"_err_en_US, - unacceptable, ultimate.name()); - emittedMessage_ = true; - } - return false; - } - - parser::ContextualMessages *messages_; - bool emittedMessage_{false}; -}; - -bool IsInitialDataTarget( - const Expr &x, parser::ContextualMessages *messages) { - IsInitialDataTargetHelper helper{messages}; - bool result{helper(x)}; - if (!result && messages && !helper.emittedMessage()) { - messages->Say( - "An initial data target must be a designator with constant subscripts"_err_en_US); - } - return result; -} - -bool IsInitialProcedureTarget(const semantics::Symbol &symbol) { - const auto &ultimate{symbol.GetUltimate()}; - return common::visit( - common::visitors{ - [&](const semantics::SubprogramDetails &subp) { - return !subp.isDummy() && !subp.stmtFunction() && - symbol.owner().kind() != semantics::Scope::Kind::MainProgram && - symbol.owner().kind() != semantics::Scope::Kind::Subprogram; - }, - [](const semantics::SubprogramNameDetails &x) { - return x.kind() != semantics::SubprogramKind::Internal; - }, - [&](const semantics::ProcEntityDetails &proc) { - return !semantics::IsPointer(ultimate) && !proc.isDummy(); - }, - [](const auto &) { return false; }, - }, - ultimate.details()); -} - -bool IsInitialProcedureTarget(const ProcedureDesignator &proc) { - if (const auto *intrin{proc.GetSpecificIntrinsic()}) { - return !intrin->isRestrictedSpecific; - } else if (proc.GetComponent()) { - return false; - } else { - return IsInitialProcedureTarget(DEREF(proc.GetSymbol())); - } -} - -bool IsInitialProcedureTarget(const Expr &expr) { - if (const auto *proc{std::get_if(&expr.u)}) { - return IsInitialProcedureTarget(*proc); - } else { - return IsNullProcedurePointer(&expr); - } -} - -class SuspiciousRealLiteralFinder - : public AnyTraverse { -public: - using Base = AnyTraverse; - SuspiciousRealLiteralFinder(int kind, FoldingContext &c) - : Base{*this}, kind_{kind}, context_{c} {} - using Base::operator(); - template - bool operator()(const Constant> &x) const { - if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) { - context_.Warn(common::UsageWarning::RealConstantWidening, - "Default real literal in REAL(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US, - kind_, x.AsFortran()); - return true; - } else { - return false; - } - } - template - bool operator()(const Constant> &x) const { - if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) { - context_.Warn(common::UsageWarning::RealConstantWidening, - "Default real literal in COMPLEX(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US, - kind_, x.AsFortran()); - return true; - } else { - return false; - } - } - template - bool operator()(const Convert, FROMCAT> &x) const { - if constexpr ((TOCAT == TypeCategory::Real || - TOCAT == TypeCategory::Complex) && - (FROMCAT == TypeCategory::Real || FROMCAT == TypeCategory::Complex)) { - auto fromType{x.left().GetType()}; - if (!fromType || fromType->kind() < TOKIND) { - return false; - } - } - return (*this)(x.left()); - } - -private: - int kind_; - FoldingContext &context_; -}; - -void CheckRealWidening(const Expr &expr, const DynamicType &toType, - FoldingContext &context) { - if (toType.category() == TypeCategory::Real || - toType.category() == TypeCategory::Complex) { - if (auto fromType{expr.GetType()}) { - if ((fromType->category() == TypeCategory::Real || - fromType->category() == TypeCategory::Complex) && - toType.kind() > fromType->kind()) { - SuspiciousRealLiteralFinder{toType.kind(), context}(expr); - } - } - } -} - -void CheckRealWidening(const Expr &expr, - const std::optional &toType, FoldingContext &context) { - if (toType) { - CheckRealWidening(expr, *toType, context); - } -} - -class InexactLiteralConversionFlagClearer - : public AnyTraverse { -public: - using Base = AnyTraverse; - InexactLiteralConversionFlagClearer() : Base(*this) {} - using Base::operator(); - template - bool operator()(const Constant> &x) const { - auto &mut{const_cast &>(x.result())}; - mut.set_isFromInexactLiteralConversion(false); - return false; - } -}; - -// Converts, folds, and then checks type, rank, and shape of an -// initialization expression for a named constant, a non-pointer -// variable static initialization, a component default initializer, -// a type parameter default value, or instantiated type parameter value. -std::optional> NonPointerInitializationExpr(const Symbol &symbol, - Expr &&x, FoldingContext &context, - const semantics::Scope *instantiation) { - CHECK(!IsPointer(symbol)); - if (auto symTS{ - characteristics::TypeAndShape::Characterize(symbol, context)}) { - auto xType{x.GetType()}; - CheckRealWidening(x, symTS->type(), context); - auto converted{ConvertToType(symTS->type(), Expr{x})}; - if (!converted && - symbol.owner().context().IsEnabled( - common::LanguageFeature::LogicalIntegerAssignment)) { - converted = DataConstantConversionExtension(context, symTS->type(), x); - if (converted) { - context.Warn(common::LanguageFeature::LogicalIntegerAssignment, - "nonstandard usage: initialization of %s with %s"_port_en_US, - symTS->type().AsFortran(), x.GetType().value().AsFortran()); - } - } - if (converted) { - auto folded{Fold(context, std::move(*converted))}; - if (IsActuallyConstant(folded)) { - InexactLiteralConversionFlagClearer{}(folded); - int symRank{symTS->Rank()}; - if (IsImpliedShape(symbol)) { - if (folded.Rank() == symRank) { - return ArrayConstantBoundChanger{ - std::move(*AsConstantExtents( - context, GetRawLowerBounds(context, NamedEntity{symbol})))} - .ChangeLbounds(std::move(folded)); - } else { - context.messages().Say( - "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US, - symbol.name(), symRank, folded.Rank()); - } - } else if (auto extents{AsConstantExtents(context, symTS->shape())}; - extents && !HasNegativeExtent(*extents)) { - if (folded.Rank() == 0 && symRank == 0) { - // symbol and constant are both scalars - return {std::move(folded)}; - } else if (folded.Rank() == 0 && symRank > 0) { - // expand the scalar constant to an array - return ScalarConstantExpander{std::move(*extents), - AsConstantExtents( - context, GetRawLowerBounds(context, NamedEntity{symbol}))} - .Expand(std::move(folded)); - } else if (auto resultShape{GetShape(context, folded)}) { - CHECK(symTS->shape()); // Assumed-ranks cannot be initialized. - if (CheckConformance(context.messages(), *symTS->shape(), - *resultShape, CheckConformanceFlags::None, - "initialized object", "initialization expression") - .value_or(false /*fail if not known now to conform*/)) { - // make a constant array with adjusted lower bounds - return ArrayConstantBoundChanger{ - std::move(*AsConstantExtents(context, - GetRawLowerBounds(context, NamedEntity{symbol})))} - .ChangeLbounds(std::move(folded)); - } - } - } else if (IsNamedConstant(symbol)) { - if (IsExplicitShape(symbol)) { - context.messages().Say( - "Named constant '%s' array must have constant shape"_err_en_US, - symbol.name()); - } else { - // Declaration checking handles other cases - } - } else { - context.messages().Say( - "Shape of initialized object '%s' must be constant"_err_en_US, - symbol.name()); - } - } else if (IsErrorExpr(folded)) { - } else if (IsLenTypeParameter(symbol)) { - return {std::move(folded)}; - } else if (IsKindTypeParameter(symbol)) { - if (instantiation) { - context.messages().Say( - "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US, - symbol.name(), folded.AsFortran()); - } else { - return {std::move(folded)}; - } - } else if (IsNamedConstant(symbol)) { - if (symbol.name() == "numeric_storage_size" && - symbol.owner().IsModule() && - DEREF(symbol.owner().symbol()).name() == "iso_fortran_env") { - // Very special case: numeric_storage_size is not folded until - // it read from the iso_fortran_env module file, as its value - // depends on compilation options. - return {std::move(folded)}; - } - context.messages().Say( - "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US, - symbol.name(), folded.AsFortran()); - } else { - context.messages().Say( - "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US, - symbol.name(), x.AsFortran()); - } - } else if (xType) { - context.messages().Say( - "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US, - symbol.name(), xType->AsFortran()); - } else { - context.messages().Say( - "Initialization expression cannot be converted to declared type of '%s'"_err_en_US, - symbol.name()); - } - } - return std::nullopt; -} - -// Specification expression validation (10.1.11(2), C1010) -class CheckSpecificationExprHelper - : public AnyTraverse> { -public: - using Result = std::optional; - using Base = AnyTraverse; - explicit CheckSpecificationExprHelper(const semantics::Scope &s, - FoldingContext &context, bool forElementalFunctionResult) - : Base{*this}, scope_{s}, context_{context}, - forElementalFunctionResult_{forElementalFunctionResult} {} - using Base::operator(); - - Result operator()(const CoarrayRef &) const { return "coindexed reference"; } - - Result operator()(const semantics::Symbol &symbol) const { - const auto &ultimate{symbol.GetUltimate()}; - const auto *object{ultimate.detailsIf()}; - bool isInitialized{semantics::IsSaved(ultimate) && - !IsAllocatable(ultimate) && object && - (ultimate.test(Symbol::Flag::InDataStmt) || - object->init().has_value())}; - bool hasHostAssociation{ - &symbol.owner() != &scope_ || &ultimate.owner() != &scope_}; - if (const auto *assoc{ - ultimate.detailsIf()}) { - return (*this)(assoc->expr()); - } else if (semantics::IsNamedConstant(ultimate) || - ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) { - return std::nullopt; - } else if (scope_.IsDerivedType() && - IsVariableName(ultimate)) { // C750, C754 - return "derived type component or type parameter value not allowed to " - "reference variable '"s + - ultimate.name().ToString() + "'"; - } else if (IsDummy(ultimate)) { - if (!inInquiry_ && forElementalFunctionResult_) { - return "dependence on value of dummy argument '"s + - ultimate.name().ToString() + "'"; - } else if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) { - return "reference to OPTIONAL dummy argument '"s + - ultimate.name().ToString() + "'"; - } else if (!inInquiry_ && !hasHostAssociation && - ultimate.attrs().test(semantics::Attr::INTENT_OUT)) { - return "reference to INTENT(OUT) dummy argument '"s + - ultimate.name().ToString() + "'"; - } else if (!ultimate.has()) { - return "dummy procedure argument"; - } else { - // Sketchy case: some compilers allow an INTENT(OUT) dummy argument - // to be used in a specification expression if it is host-associated. - // The arguments raised in support this usage, however, depend on - // a reading of the standard that would also accept an OPTIONAL - // host-associated dummy argument, and that doesn't seem like a - // good idea. - if (!inInquiry_ && hasHostAssociation && - ultimate.attrs().test(semantics::Attr::INTENT_OUT)) { - context_.Warn(common::UsageWarning::HostAssociatedIntentOutInSpecExpr, - "specification expression refers to host-associated INTENT(OUT) dummy argument '%s'"_port_en_US, - ultimate.name()); - } - return std::nullopt; - } - } else if (hasHostAssociation) { - return std::nullopt; // host association is in play - } else if (isInitialized && - context_.languageFeatures().IsEnabled( - common::LanguageFeature::SavedLocalInSpecExpr)) { - context_.Warn(common::LanguageFeature::SavedLocalInSpecExpr, - "specification expression refers to local object '%s' (initialized and saved)"_port_en_US, - ultimate.name()); - return std::nullopt; - } else if (const auto *object{ - ultimate.detailsIf()}) { - if (object->commonBlock()) { - return std::nullopt; - } - } - if (inInquiry_) { - return std::nullopt; - } else { - return "reference to local entity '"s + ultimate.name().ToString() + "'"; - } - } - - Result operator()(const Component &x) const { - // Don't look at the component symbol. - return (*this)(x.base()); - } - Result operator()(const ArrayRef &x) const { - if (auto result{(*this)(x.base())}) { - return result; - } - // The subscripts don't get special protection for being in a - // specification inquiry context; - auto restorer{common::ScopedSet(inInquiry_, false)}; - return (*this)(x.subscript()); - } - Result operator()(const Substring &x) const { - if (auto result{(*this)(x.parent())}) { - return result; - } - // The bounds don't get special protection for being in a - // specification inquiry context; - auto restorer{common::ScopedSet(inInquiry_, false)}; - if (auto result{(*this)(x.lower())}) { - return result; - } - return (*this)(x.upper()); - } - Result operator()(const DescriptorInquiry &x) const { - // Many uses of SIZE(), LBOUND(), &c. that are valid in specification - // expressions will have been converted to expressions over descriptor - // inquiries by Fold(). - // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X)) - if (IsPermissibleInquiry( - x.base().GetFirstSymbol(), x.base().GetLastSymbol(), x.field())) { - auto restorer{common::ScopedSet(inInquiry_, true)}; - return (*this)(x.base()); - } else if (IsConstantExpr(x)) { - return std::nullopt; - } else { - return "non-constant descriptor inquiry not allowed for local object"; - } - } - - Result operator()(const TypeParamInquiry &inq) const { - if (scope_.IsDerivedType()) { - if (!IsConstantExpr(inq) && - inq.base() /* X%T, not local T */) { // C750, C754 - return "non-constant reference to a type parameter inquiry not allowed " - "for derived type components or type parameter values"; - } - } else if (inq.base() && - IsInquiryAlwaysPermissible(inq.base()->GetFirstSymbol())) { - auto restorer{common::ScopedSet(inInquiry_, true)}; - return (*this)(inq.base()); - } else if (!IsConstantExpr(inq)) { - return "non-constant type parameter inquiry not allowed for local object"; - } - return std::nullopt; - } - - Result operator()(const ProcedureRef &x) const { - if (const auto *symbol{x.proc().GetSymbol()}) { - const Symbol &ultimate{symbol->GetUltimate()}; - if (!semantics::IsPureProcedure(ultimate)) { - return "reference to impure function '"s + ultimate.name().ToString() + - "'"; - } - if (semantics::IsStmtFunction(ultimate)) { - return "reference to statement function '"s + - ultimate.name().ToString() + "'"; - } - if (scope_.IsDerivedType()) { // C750, C754 - return "reference to function '"s + ultimate.name().ToString() + - "' not allowed for derived type components or type parameter" - " values"; - } - if (auto procChars{characteristics::Procedure::Characterize( - x.proc(), context_, /*emitError=*/true)}) { - const auto iter{std::find_if(procChars->dummyArguments.begin(), - procChars->dummyArguments.end(), - [](const characteristics::DummyArgument &dummy) { - return std::holds_alternative( - dummy.u); - })}; - if (iter != procChars->dummyArguments.end() && - ultimate.name().ToString() != "__builtin_c_funloc") { - return "reference to function '"s + ultimate.name().ToString() + - "' with dummy procedure argument '" + iter->name + '\''; - } - } - // References to internal functions are caught in expression semantics. - // TODO: other checks for standard module procedures - auto restorer{common::ScopedSet(inInquiry_, false)}; - return (*this)(x.arguments()); - } else { // intrinsic - const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; - bool inInquiry{context_.intrinsics().GetIntrinsicClass(intrin.name) == - IntrinsicClass::inquiryFunction}; - if (scope_.IsDerivedType()) { // C750, C754 - if ((context_.intrinsics().IsIntrinsic(intrin.name) && - badIntrinsicsForComponents_.find(intrin.name) != - badIntrinsicsForComponents_.end())) { - return "reference to intrinsic '"s + intrin.name + - "' not allowed for derived type components or type parameter" - " values"; - } - if (inInquiry && !IsConstantExpr(x)) { - return "non-constant reference to inquiry intrinsic '"s + - intrin.name + - "' not allowed for derived type components or type" - " parameter values"; - } - } - // Type-determined inquiries (DIGITS, HUGE, &c.) will have already been - // folded and won't arrive here. Inquiries that are represented with - // DescriptorInquiry operations (LBOUND) are checked elsewhere. If a - // call that makes it to here satisfies the requirements of a constant - // expression (as Fortran defines it), it's fine. - if (IsConstantExpr(x)) { - return std::nullopt; - } - if (intrin.name == "present") { - return std::nullopt; // always ok - } - const auto &proc{intrin.characteristics.value()}; - std::size_t j{0}; - for (const auto &arg : x.arguments()) { - bool checkArg{true}; - if (const auto *dataDummy{j < proc.dummyArguments.size() - ? std::get_if( - &proc.dummyArguments[j].u) - : nullptr}) { - if (dataDummy->attrs.test(characteristics::DummyDataObject::Attr:: - OnlyIntrinsicInquiry)) { - checkArg = false; // value unused, e.g. IEEE_SUPPORT_FLAG(,,,. X) - } - } - if (arg && checkArg) { - // Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y - if (inInquiry) { - if (auto dataRef{ExtractDataRef(*arg, true, true)}) { - if (intrin.name == "allocated" || intrin.name == "associated" || - intrin.name == "is_contiguous") { // ok - } else if (intrin.name == "len" && - IsPermissibleInquiry(dataRef->GetFirstSymbol(), - dataRef->GetLastSymbol(), - DescriptorInquiry::Field::Len)) { // ok - } else if (intrin.name == "lbound" && - IsPermissibleInquiry(dataRef->GetFirstSymbol(), - dataRef->GetLastSymbol(), - DescriptorInquiry::Field::LowerBound)) { // ok - } else if ((intrin.name == "shape" || intrin.name == "size" || - intrin.name == "sizeof" || - intrin.name == "storage_size" || - intrin.name == "ubound") && - IsPermissibleInquiry(dataRef->GetFirstSymbol(), - dataRef->GetLastSymbol(), - DescriptorInquiry::Field::Extent)) { // ok - } else { - return "non-constant inquiry function '"s + intrin.name + - "' not allowed for local object"; - } - } - } - auto restorer{common::ScopedSet(inInquiry_, inInquiry)}; - if (auto err{(*this)(*arg)}) { - return err; - } - } - ++j; - } - return std::nullopt; - } - } - -private: - const semantics::Scope &scope_; - FoldingContext &context_; - // Contextual information: this flag is true when in an argument to - // an inquiry intrinsic like SIZE(). - mutable bool inInquiry_{false}; - bool forElementalFunctionResult_{false}; // F'2023 C15121 - const std::set badIntrinsicsForComponents_{ - "allocated", "associated", "extends_type_of", "present", "same_type_as"}; - - bool IsInquiryAlwaysPermissible(const semantics::Symbol &) const; - bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol, - const semantics::Symbol &lastSymbol, - DescriptorInquiry::Field field) const; -}; - -bool CheckSpecificationExprHelper::IsInquiryAlwaysPermissible( - const semantics::Symbol &symbol) const { - if (&symbol.owner() != &scope_ || symbol.has() || - symbol.owner().kind() == semantics::Scope::Kind::Module || - semantics::FindCommonBlockContaining(symbol) || - symbol.has()) { - return true; // it's nonlocal - } else if (semantics::IsDummy(symbol) && !forElementalFunctionResult_) { - return true; - } else { - return false; - } -} - -bool CheckSpecificationExprHelper::IsPermissibleInquiry( - const semantics::Symbol &firstSymbol, const semantics::Symbol &lastSymbol, - DescriptorInquiry::Field field) const { - if (IsInquiryAlwaysPermissible(firstSymbol)) { - return true; - } - // Inquiries on local objects may not access a deferred bound or length. - // (This code used to be a switch, but it proved impossible to write it - // thus without running afoul of bogus warnings from different C++ - // compilers.) - if (field == DescriptorInquiry::Field::Rank) { - return true; // always known - } - const auto *object{lastSymbol.detailsIf()}; - if (field == DescriptorInquiry::Field::LowerBound || - field == DescriptorInquiry::Field::Extent || - field == DescriptorInquiry::Field::Stride) { - return object && !object->shape().CanBeDeferredShape(); - } - if (field == DescriptorInquiry::Field::Len) { - return object && object->type() && - object->type()->category() == semantics::DeclTypeSpec::Character && - !object->type()->characterTypeSpec().length().isDeferred(); - } - return false; -} - -template -void CheckSpecificationExpr(const A &x, const semantics::Scope &scope, - FoldingContext &context, bool forElementalFunctionResult) { - CheckSpecificationExprHelper errors{ - scope, context, forElementalFunctionResult}; - if (auto why{errors(x)}) { - context.messages().Say("Invalid specification expression%s: %s"_err_en_US, - forElementalFunctionResult ? " for elemental function result" : "", - *why); - } -} - -template void CheckSpecificationExpr(const Expr &, - const semantics::Scope &, FoldingContext &, - bool forElementalFunctionResult); -template void CheckSpecificationExpr(const Expr &, - const semantics::Scope &, FoldingContext &, - bool forElementalFunctionResult); -template void CheckSpecificationExpr(const Expr &, - const semantics::Scope &, FoldingContext &, - bool forElementalFunctionResult); -template void CheckSpecificationExpr(const std::optional> &, - const semantics::Scope &, FoldingContext &, - bool forElementalFunctionResult); -template void CheckSpecificationExpr(const std::optional> &, - const semantics::Scope &, FoldingContext &, - bool forElementalFunctionResult); -template void CheckSpecificationExpr( - const std::optional> &, const semantics::Scope &, - FoldingContext &, bool forElementalFunctionResult); - -// IsContiguous() -- 9.5.4 -class IsContiguousHelper - : public AnyTraverse> { -public: - using Result = std::optional; // tri-state - using Base = AnyTraverse; - explicit IsContiguousHelper(FoldingContext &c, - bool namedConstantSectionsAreContiguous, - bool firstDimensionStride1 = false) - : Base{*this}, context_{c}, - namedConstantSectionsAreContiguous_{namedConstantSectionsAreContiguous}, - firstDimensionStride1_{firstDimensionStride1} {} - using Base::operator(); - - template Result operator()(const Constant &) const { - return true; - } - Result operator()(const StaticDataObject &) const { return true; } - Result operator()(const semantics::Symbol &symbol) const { - const auto &ultimate{symbol.GetUltimate()}; - if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) { - return true; - } else if (!IsVariable(symbol)) { - return true; - } else if (ultimate.Rank() == 0) { - // Extension: accept scalars as a degenerate case of - // simple contiguity to allow their use in contexts like - // data targets in pointer assignments with remapping. - return true; - } else if (const auto *details{ - ultimate.detailsIf()}) { - // RANK(*) associating entity is contiguous. - if (details->IsAssumedSize()) { - return true; - } else if (!IsVariable(details->expr()) && - (namedConstantSectionsAreContiguous_ || - !ExtractDataRef(details->expr(), true, true))) { - // Selector is associated to an expression value. - return true; - } else { - return Base::operator()(ultimate); // use expr - } - } else if (semantics::IsPointer(ultimate) || IsAssumedShape(ultimate) || - IsAssumedRank(ultimate)) { - return std::nullopt; - } else if (ultimate.has()) { - return true; - } else { - return Base::operator()(ultimate); - } - } - - Result operator()(const ArrayRef &x) const { - if (x.Rank() == 0) { - return true; // scalars considered contiguous - } - int subscriptRank{0}; - auto baseLbounds{GetLBOUNDs(context_, x.base())}; - auto baseUbounds{GetUBOUNDs(context_, x.base())}; - auto subscripts{CheckSubscripts( - x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)}; - if (!subscripts.value_or(false)) { - return subscripts; // subscripts not known to be contiguous - } else if (subscriptRank > 0) { - // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous. - return (*this)(x.base()); - } else { - // a(:)%b(1,1) is (probably) not contiguous. - return std::nullopt; - } - } - Result operator()(const CoarrayRef &x) const { return (*this)(x.base()); } - Result operator()(const Component &x) const { - if (x.base().Rank() == 0) { - return (*this)(x.GetLastSymbol()); - } else { - const DataRef &base{x.base()}; - if (Result baseIsContiguous{(*this)(base)}) { - if (!*baseIsContiguous) { - return false; - } else { - bool sizeKnown{false}; - if (auto constShape{GetConstantExtents(context_, x)}) { - sizeKnown = true; - if (GetSize(*constShape) <= 1) { - return true; // empty or singleton - } - } - const Symbol &last{base.GetLastSymbol()}; - if (auto type{DynamicType::From(last)}) { - CHECK(type->category() == TypeCategory::Derived); - if (!type->IsPolymorphic()) { - const auto &derived{type->GetDerivedTypeSpec()}; - if (const auto *scope{derived.scope()}) { - auto iter{scope->begin()}; - if (++iter == scope->end()) { - return true; // type has but one component - } else if (sizeKnown) { - return false; // multiple components & array size is known > 1 - } - } - } - } - } - } - return std::nullopt; - } - } - Result operator()(const ComplexPart &x) const { - // TODO: should be true when base is empty array or singleton, too - return x.complex().Rank() == 0; - } - Result operator()(const Substring &x) const { - if (x.Rank() == 0) { - return true; // scalar substring always contiguous - } - // Substrings with rank must have DataRefs as their parents - const DataRef &parentDataRef{DEREF(x.GetParentIf())}; - std::optional len; - if (auto lenExpr{parentDataRef.LEN()}) { - len = ToInt64(Fold(context_, std::move(*lenExpr))); - if (len) { - if (*len <= 0) { - return true; // empty substrings - } else if (*len == 1) { - // Substrings can't be incomplete; is base array contiguous? - return (*this)(parentDataRef); - } - } - } - std::optional upper; - bool upperIsLen{false}; - if (auto upperExpr{x.upper()}) { - upper = ToInt64(Fold(context_, common::Clone(*upperExpr))); - if (upper) { - if (*upper < 1) { - return true; // substring(n:0) empty - } - upperIsLen = len && *upper >= *len; - } else if (const auto *inquiry{ - UnwrapConvertedExpr(*upperExpr)}; - inquiry && inquiry->field() == DescriptorInquiry::Field::Len) { - upperIsLen = - &parentDataRef.GetLastSymbol() == &inquiry->base().GetLastSymbol(); - } - } else { - upperIsLen = true; // substring(n:) - } - if (auto lower{ToInt64(Fold(context_, x.lower()))}) { - if (*lower == 1 && upperIsLen) { - // known complete substring; is base contiguous? - return (*this)(parentDataRef); - } else if (upper) { - if (*upper < *lower) { - return true; // empty substring(3:2) - } else if (*lower > 1) { - return false; // known incomplete substring - } else if (len && *upper < *len) { - return false; // known incomplete substring - } - } - } - return std::nullopt; // contiguity not known - } - - Result operator()(const ProcedureRef &x) const { - if (auto chars{characteristics::Procedure::Characterize( - x.proc(), context_, /*emitError=*/true)}) { - if (chars->functionResult) { - const auto &result{*chars->functionResult}; - if (!result.IsProcedurePointer()) { - if (result.attrs.test( - characteristics::FunctionResult::Attr::Contiguous)) { - return true; - } - if (!result.attrs.test( - characteristics::FunctionResult::Attr::Pointer)) { - return true; - } - if (const auto *type{result.GetTypeAndShape()}; - type && type->Rank() == 0) { - return true; // pointer to scalar - } - // Must be non-CONTIGUOUS pointer to array - } - } - } - return std::nullopt; - } - - Result operator()(const NullPointer &) const { return true; } - -private: - // Returns "true" for a provably empty or simply contiguous array section; - // return "false" for a provably nonempty discontiguous section or for use - // of a vector subscript. - std::optional CheckSubscripts(const std::vector &subscript, - int &rank, const Shape *baseLbounds = nullptr, - const Shape *baseUbounds = nullptr) const { - bool anyTriplet{false}; - rank = 0; - // Detect any provably empty dimension in this array section, which would - // render the whole section empty and therefore vacuously contiguous. - std::optional result; - bool mayBeEmpty{false}; - auto dims{subscript.size()}; - std::vector knownPartialSlice(dims, false); - for (auto j{dims}; j-- > 0;) { - if (j == 0 && firstDimensionStride1_ && !result.value_or(true)) { - result.reset(); // ignore problems on later dimensions - } - std::optional dimLbound; - std::optional dimUbound; - std::optional dimExtent; - if (baseLbounds && j < baseLbounds->size()) { - if (const auto &lb{baseLbounds->at(j)}) { - dimLbound = ToInt64(Fold(context_, Expr{*lb})); - } - } - if (baseUbounds && j < baseUbounds->size()) { - if (const auto &ub{baseUbounds->at(j)}) { - dimUbound = ToInt64(Fold(context_, Expr{*ub})); - } - } - if (dimLbound && dimUbound) { - if (*dimLbound <= *dimUbound) { - dimExtent = *dimUbound - *dimLbound + 1; - } else { - // This is an empty dimension. - result = true; - dimExtent = 0; - } - } - if (const auto *triplet{std::get_if(&subscript[j].u)}) { - ++rank; - const Expr *lowerBound{triplet->GetLower()}; - const Expr *upperBound{triplet->GetUpper()}; - std::optional lowerVal{lowerBound - ? ToInt64(Fold(context_, Expr{*lowerBound})) - : dimLbound}; - std::optional upperVal{upperBound - ? ToInt64(Fold(context_, Expr{*upperBound})) - : dimUbound}; - if (auto stride{ToInt64(triplet->stride())}) { - if (j == 0 && *stride == 1 && firstDimensionStride1_) { - result = *stride == 1; // contiguous or empty if so - } - if (lowerVal && upperVal) { - if (*lowerVal < *upperVal) { - if (*stride < 0) { - result = true; // empty dimension - } else if (!result && *stride > 1 && - *lowerVal + *stride <= *upperVal) { - result = false; // discontiguous if not empty - } - } else if (*lowerVal > *upperVal) { - if (*stride > 0) { - result = true; // empty dimension - } else if (!result && *stride < 0 && - *lowerVal + *stride >= *upperVal) { - result = false; // discontiguous if not empty - } - } else { // bounds known and equal - if (j == 0 && firstDimensionStride1_) { - result = true; // stride doesn't matter - } - } - } else { // bounds not both known - mayBeEmpty = true; - } - } else { // stride not known - if (lowerVal && upperVal && *lowerVal == *upperVal) { - // stride doesn't matter when bounds are equal - if (j == 0 && firstDimensionStride1_) { - result = true; - } - } else { - mayBeEmpty = true; - } - } - } else if (subscript[j].Rank() > 0) { // vector subscript - ++rank; - if (!result) { - result = false; - } - mayBeEmpty = true; - } else { // scalar subscript - if (dimExtent && *dimExtent > 1) { - knownPartialSlice[j] = true; - } - } - } - if (rank == 0) { - result = true; // scalar - } - if (result) { - return result; - } - // Not provably contiguous or discontiguous at this point. - // Return "true" if simply contiguous, otherwise nullopt. - for (auto j{subscript.size()}; j-- > 0;) { - if (const auto *triplet{std::get_if(&subscript[j].u)}) { - auto stride{ToInt64(triplet->stride())}; - if (!stride || stride != 1) { - return std::nullopt; - } else if (anyTriplet) { - if (triplet->GetLower() || triplet->GetUpper()) { - // all triplets before the last one must be just ":" for - // simple contiguity - return std::nullopt; - } - } else { - anyTriplet = true; - } - ++rank; - } else if (anyTriplet) { - // If the section cannot be empty, and this dimension's - // scalar subscript is known not to cover the whole - // dimension, then the array section is provably - // discontiguous. - return (mayBeEmpty || !knownPartialSlice[j]) - ? std::nullopt - : std::make_optional(false); - } - } - return true; // simply contiguous - } - - FoldingContext &context_; - bool namedConstantSectionsAreContiguous_{false}; - bool firstDimensionStride1_{false}; -}; - -template -std::optional IsContiguous(const A &x, FoldingContext &context, - bool namedConstantSectionsAreContiguous, bool firstDimensionStride1) { - if (!IsVariable(x) && - (namedConstantSectionsAreContiguous || !ExtractDataRef(x, true, true))) { - return true; - } else { - return IsContiguousHelper{ - context, namedConstantSectionsAreContiguous, firstDimensionStride1}(x); - } -} - -std::optional IsContiguous(const ActualArgument &actual, - FoldingContext &fc, bool namedConstantSectionsAreContiguous, - bool firstDimensionStride1) { - auto *expr{actual.UnwrapExpr()}; - return expr && - IsContiguous( - *expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1); -} - -template std::optional IsContiguous(const Expr &, - FoldingContext &, bool namedConstantSectionsAreContiguous, - bool firstDimensionStride1); -template std::optional IsContiguous(const ActualArgument &, - FoldingContext &, bool namedConstantSectionsAreContiguous, - bool firstDimensionStride1); -template std::optional IsContiguous(const ArrayRef &, FoldingContext &, - bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); -template std::optional IsContiguous(const Substring &, FoldingContext &, - bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); -template std::optional IsContiguous(const Component &, FoldingContext &, - bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); -template std::optional IsContiguous(const ComplexPart &, FoldingContext &, - bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); -template std::optional IsContiguous(const CoarrayRef &, FoldingContext &, - bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); -template std::optional IsContiguous(const Symbol &, FoldingContext &, - bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); - -// IsErrorExpr() -struct IsErrorExprHelper : public AnyTraverse { - using Result = bool; - using Base = AnyTraverse; - IsErrorExprHelper() : Base{*this} {} - using Base::operator(); - - bool operator()(const SpecificIntrinsic &x) { - return x.name == IntrinsicProcTable::InvalidName; - } -}; - -template bool IsErrorExpr(const A &x) { - return IsErrorExprHelper{}(x); -} - -template bool IsErrorExpr(const Expr &); - -// C1577 -// TODO: Also check C1579 & C1582 here -class StmtFunctionChecker - : public AnyTraverse> { -public: - using Result = std::optional; - using Base = AnyTraverse; - - static constexpr auto feature{ - common::LanguageFeature::StatementFunctionExtensions}; - - StmtFunctionChecker(const Symbol &sf, FoldingContext &context) - : Base{*this}, sf_{sf}, context_{context} { - if (!context_.languageFeatures().IsEnabled(feature)) { - severity_ = parser::Severity::Error; - } else if (context_.languageFeatures().ShouldWarn(feature)) { - severity_ = parser::Severity::Portability; - } - } - using Base::operator(); - - Result Return(parser::Message &&msg) const { - if (severity_) { - msg.set_severity(*severity_); - if (*severity_ != parser::Severity::Error) { - msg.set_languageFeature(feature); - } - } - return std::move(msg); - } - - template Result operator()(const ArrayConstructor &) const { - if (severity_) { - return Return(parser::Message{sf_.name(), - "Statement function '%s' should not contain an array constructor"_port_en_US, - sf_.name()}); - } else { - return std::nullopt; - } - } - Result operator()(const StructureConstructor &) const { - if (severity_) { - return Return(parser::Message{sf_.name(), - "Statement function '%s' should not contain a structure constructor"_port_en_US, - sf_.name()}); - } else { - return std::nullopt; - } - } - Result operator()(const TypeParamInquiry &) const { - if (severity_) { - return Return(parser::Message{sf_.name(), - "Statement function '%s' should not contain a type parameter inquiry"_port_en_US, - sf_.name()}); - } else { - return std::nullopt; - } - } - Result operator()(const ProcedureDesignator &proc) const { - if (const Symbol * symbol{proc.GetSymbol()}) { - const Symbol &ultimate{symbol->GetUltimate()}; - if (const auto *subp{ - ultimate.detailsIf()}) { - if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) { - if (ultimate.name().begin() > sf_.name().begin()) { - return parser::Message{sf_.name(), - "Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US, - sf_.name(), ultimate.name()}; - } - } - } - if (auto chars{characteristics::Procedure::Characterize( - proc, context_, /*emitError=*/true)}) { - if (!chars->CanBeCalledViaImplicitInterface()) { - if (severity_) { - return Return(parser::Message{sf_.name(), - "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US, - sf_.name(), symbol->name()}); - } - } - } - } - if (proc.Rank() > 0) { - if (severity_) { - return Return(parser::Message{sf_.name(), - "Statement function '%s' should not reference a function that returns an array"_port_en_US, - sf_.name()}); - } - } - return std::nullopt; - } - Result operator()(const ActualArgument &arg) const { - if (const auto *expr{arg.UnwrapExpr()}) { - if (auto result{(*this)(*expr)}) { - return result; - } - if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) { - if (severity_) { - return Return(parser::Message{sf_.name(), - "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US, - sf_.name()}); - } - } - } - return std::nullopt; - } - -private: - const Symbol &sf_; - FoldingContext &context_; - std::optional severity_; -}; - -std::optional CheckStatementFunction( - const Symbol &sf, const Expr &expr, FoldingContext &context) { - return StmtFunctionChecker{sf, context}(expr); -} - -// Helper class for checking differences between actual and dummy arguments -class CopyInOutExplicitInterface { -public: - explicit CopyInOutExplicitInterface(FoldingContext &fc, - const ActualArgument &actual, - const characteristics::DummyDataObject &dummyObj) - : fc_{fc}, actual_{actual}, dummyObj_{dummyObj} {} - - // Returns true, if actual and dummy have different contiguity requirements - bool HaveContiguityDifferences() const { - // Check actual contiguity, unless dummy doesn't care - bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)}; - bool actualTreatAsContiguous{ - dummyObj_.ignoreTKR.test(common::IgnoreTKR::Contiguous) || - IsSimplyContiguous(actual_, fc_)}; - bool dummyIsExplicitShape{dummyObj_.type.IsExplicitShape()}; - bool dummyIsAssumedSize{dummyObj_.type.attrs().test( - characteristics::TypeAndShape::Attr::AssumedSize)}; - bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()}; - // type(*) with IGNORE_TKR(tkr) is often used to interface with C "void*". - // Since the other languages don't know about Fortran's discontiguity - // handling, such cases should require contiguity. - bool dummyIsVoidStar{dummyObj_.type.type().IsAssumedType() && - dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type) && - dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank) && - dummyObj_.ignoreTKR.test(common::IgnoreTKR::Kind)}; - // Explicit shape and assumed size arrays must be contiguous - bool dummyNeedsContiguity{dummyIsExplicitShape || dummyIsAssumedSize || - (dummyTreatAsArray && !dummyIsPolymorphic) || dummyIsVoidStar || - dummyObj_.attrs.test( - characteristics::DummyDataObject::Attr::Contiguous)}; - return !actualTreatAsContiguous && dummyNeedsContiguity; - } - - // Returns true, if actual and dummy have polymorphic differences - bool HavePolymorphicDifferences() const { - bool dummyIsAssumedRank{dummyObj_.type.attrs().test( - characteristics::TypeAndShape::Attr::AssumedRank)}; - bool actualIsAssumedRank{semantics::IsAssumedRank(actual_)}; - bool dummyIsAssumedShape{dummyObj_.type.attrs().test( - characteristics::TypeAndShape::Attr::AssumedShape)}; - bool actualIsAssumedShape{semantics::IsAssumedShape(actual_)}; - if ((actualIsAssumedRank && dummyIsAssumedRank) || - (actualIsAssumedShape && dummyIsAssumedShape)) { - // Assumed-rank and assumed-shape arrays are represented by descriptors, - // so don't need to do polymorphic check. - } else if (!dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) { - // flang supports limited cases of passing polymorphic to non-polimorphic. - // These cases require temporary of non-polymorphic type. (For example, - // the actual argument could be polymorphic array of child type, - // while the dummy argument could be non-polymorphic array of parent - // type.) - bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()}; - auto actualType{ - characteristics::TypeAndShape::Characterize(actual_, fc_)}; - bool actualIsPolymorphic{ - actualType && actualType->type().IsPolymorphic()}; - if (actualIsPolymorphic && !dummyIsPolymorphic) { - return true; - } - } - return false; - } - - bool HaveArrayOrAssumedRankArgs() const { - bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)}; - return IsArrayOrAssumedRank(actual_) && - (IsArrayOrAssumedRank(dummyObj_) || dummyTreatAsArray); - } - - bool PassByValue() const { - return dummyObj_.attrs.test(characteristics::DummyDataObject::Attr::Value); - } - - bool HaveCoarrayDifferences() const { - return ExtractCoarrayRef(actual_) && dummyObj_.type.corank() == 0; - } - - bool HasIntentOut() const { return dummyObj_.intent == common::Intent::Out; } - - bool HasIntentIn() const { return dummyObj_.intent == common::Intent::In; } - - static bool IsArrayOrAssumedRank(const ActualArgument &actual) { - return semantics::IsAssumedRank(actual) || actual.Rank() > 0; - } - - static bool IsArrayOrAssumedRank( - const characteristics::DummyDataObject &dummy) { - return dummy.type.attrs().test( - characteristics::TypeAndShape::Attr::AssumedRank) || - dummy.type.Rank() > 0; - } - -private: - FoldingContext &fc_; - const ActualArgument &actual_; - const characteristics::DummyDataObject &dummyObj_; -}; - -// If forCopyOut is false, returns if a particular actual/dummy argument -// combination may need a temporary creation with copy-in operation. If -// forCopyOut is true, returns the same for copy-out operation. For -// procedures with explicit interface, it's expected that "dummy" is not null. -// For procedures with implicit interface dummy may be null. -// -// Note that these copy-in and copy-out checks are done from the caller's -// perspective, meaning that for copy-in the caller need to do the copy -// before calling the callee. Similarly, for copy-out the caller is expected -// to do the copy after the callee returns. -bool MayNeedCopy(const ActualArgument *actual, - const characteristics::DummyArgument *dummy, FoldingContext &fc, - bool forCopyOut) { - if (!actual) { - return false; - } - if (actual->isAlternateReturn()) { - return false; - } - const auto *dummyObj{dummy - ? std::get_if(&dummy->u) - : nullptr}; - const bool forCopyIn = !forCopyOut; - if (!evaluate::IsVariable(*actual)) { - // Actual argument expressions that aren’t variables are copy-in, but - // not copy-out. - return forCopyIn; - } - if (dummyObj) { // Explict interface - CopyInOutExplicitInterface check{fc, *actual, *dummyObj}; - if (forCopyOut && check.HasIntentIn()) { - // INTENT(IN) dummy args never need copy-out - return false; - } - if (forCopyIn && check.HasIntentOut()) { - // INTENT(OUT) dummy args never need copy-in - return false; - } - if (check.PassByValue()) { - // Pass by value, always copy-in, never copy-out - return forCopyIn; - } - if (check.HaveCoarrayDifferences()) { - return true; - } - // Note: contiguity and polymorphic checks deal with array or assumed rank - // arguments - if (!check.HaveArrayOrAssumedRankArgs()) { - return false; - } - if (check.HaveContiguityDifferences()) { - return true; - } - if (check.HavePolymorphicDifferences()) { - return true; - } - } else { // Implicit interface - if (ExtractCoarrayRef(*actual)) { - // Coindexed actual args may need copy-in and copy-out with implicit - // interface - return true; - } - if (!IsSimplyContiguous(*actual, fc)) { - // Copy-in: actual arguments that are variables are copy-in when - // non-contiguous. - // Copy-out: vector subscripts could refer to duplicate elements, can't - // copy out. - return !(forCopyOut && HasVectorSubscript(*actual)); - } - } - // For everything else, no copy-in or copy-out - return false; -} - -} // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 1f3cbbf6a0c36..20f2961de9f54 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -100,7 +100,7 @@ auto IsVariableHelper::operator()(const Substring &x) const -> Result { } auto IsVariableHelper::operator()(const ProcedureDesignator &x) const -> Result { - if (const Symbol * symbol{x.GetSymbol()}) { + if (const Symbol *symbol{x.GetSymbol()}) { const Symbol *result{FindFunctionResult(*symbol)}; return result && IsPointer(*result) && !IsProcedurePointer(*result); } @@ -903,7 +903,7 @@ bool IsProcedurePointer(const Expr &expr) { if (IsNullProcedurePointer(&expr)) { return true; } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) { - if (const Symbol * proc{funcRef->proc().GetSymbol()}) { + if (const Symbol *proc{funcRef->proc().GetSymbol()}) { const Symbol *result{FindFunctionResult(*proc)}; return result && IsProcedurePointer(*result); } else { @@ -940,7 +940,7 @@ bool IsObjectPointer(const Expr &expr) { return false; } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) { return IsVariable(*funcRef); - } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) { + } else if (const Symbol *symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) { return IsPointer(symbol->GetUltimate()); } else { return false; @@ -1294,6 +1294,12 @@ std::optional CheckProcCompatibility(bool isCall, } else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) { msg = "PURE procedure %s may not be associated with non-PURE" " procedure designator '%s'"_err_en_US; + } else if (lhsProcedure->IsSimple() && !rhsProcedure->IsSimple()) { + msg = "SIMPLE procedure %s may not be associated with non-SIMPLE" + " procedure designator '%s'"_err_en_US; + } else if (!lhsProcedure->IsSimple() && rhsProcedure->IsSimple()) { + msg = "non-SIMPLE procedure %s may not be associated with SIMPLE" + " procedure designator '%s'"_err_en_US; } else if (lhsProcedure->IsFunction() && rhsProcedure->IsSubroutine()) { msg = "Function %s may not be associated with subroutine" " designator '%s'"_err_en_US; @@ -1338,7 +1344,7 @@ const Symbol *UnwrapWholeSymbolDataRef(const std::optional &dataRef) { } const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &dataRef) { - if (const Component * c{std::get_if(&dataRef.u)}) { + if (const Component *c{std::get_if(&dataRef.u)}) { return c->base().Rank() == 0 ? &c->GetLastSymbol() : nullptr; } else { return UnwrapWholeSymbolDataRef(dataRef); @@ -1351,7 +1357,7 @@ const Symbol *UnwrapWholeSymbolOrComponentDataRef( } const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &dataRef) { - if (const CoarrayRef * c{std::get_if(&dataRef.u)}) { + if (const CoarrayRef *c{std::get_if(&dataRef.u)}) { return UnwrapWholeSymbolOrComponentOrCoarrayRef(c->base()); } else { return UnwrapWholeSymbolOrComponentDataRef(dataRef); @@ -1415,7 +1421,7 @@ static std::optional> DataConstantConversionHelper( auto at{fromConst->lbounds()}; auto shape{fromConst->shape()}; for (auto n{GetSize(shape)}; n-- > 0; - fromConst->IncrementSubscripts(at)) { + fromConst->IncrementSubscripts(at)) { auto elt{fromConst->At(at)}; if constexpr (TO == TypeCategory::Logical) { values.emplace_back(std::move(elt)); @@ -1466,8 +1472,8 @@ bool IsAllocatableOrPointerObject(const Expr &expr) { bool IsAllocatableDesignator(const Expr &expr) { // Allocatable sub-objects are not themselves allocatable (9.5.3.1 NOTE 2). - if (const semantics::Symbol * - sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) { + if (const semantics::Symbol *sym{ + UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) { return semantics::IsAllocatable(sym->GetUltimate()); } return false; @@ -1960,7 +1966,7 @@ const Symbol &ResolveAssociations( if (const auto *details{symbol.detailsIf()}) { if (!details->rank() /* not RANK(n) or RANK(*) */ && !(stopAtTypeGuard && details->isTypeGuard())) { - if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) { + if (const Symbol *nested{UnwrapWholeSymbolDataRef(details->expr())}) { return ResolveAssociations(*nested); } } @@ -1975,7 +1981,7 @@ const Symbol &ResolveAssociations( static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) { if (const auto &expr{details.expr()}) { if (IsVariable(*expr) && !HasVectorSubscript(*expr)) { - if (const Symbol * varSymbol{GetFirstSymbol(*expr)}) { + if (const Symbol *varSymbol{GetFirstSymbol(*expr)}) { return &GetAssociationRoot(*varSymbol); } } @@ -1986,7 +1992,7 @@ static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) { const Symbol &GetAssociationRoot(const Symbol &original, bool stopAtTypeGuard) { const Symbol &symbol{ResolveAssociations(original, stopAtTypeGuard)}; if (const auto *details{symbol.detailsIf()}) { - if (const Symbol * root{GetAssociatedVariable(*details)}) { + if (const Symbol *root{GetAssociatedVariable(*details)}) { return *root; } } @@ -1996,8 +2002,8 @@ const Symbol &GetAssociationRoot(const Symbol &original, bool stopAtTypeGuard) { const Symbol *GetMainEntry(const Symbol *symbol) { if (symbol) { if (const auto *subpDetails{symbol->detailsIf()}) { - if (const Scope * scope{subpDetails->entryScope()}) { - if (const Symbol * main{scope->symbol()}) { + if (const Scope *scope{subpDetails->entryScope()}) { + if (const Symbol *main{scope->symbol()}) { return main; } } @@ -2064,6 +2070,15 @@ bool IsPureProcedure(const Scope &scope) { return symbol && IsPureProcedure(*symbol); } +bool IsSimpleProcedure(const Symbol &original) { + return original.attrs().test(Attr::SIMPLE); +} + +bool IsSimpleProcedure(const Scope &scope) { + const Symbol *symbol{scope.GetSymbol()}; + return symbol && IsSimpleProcedure(*symbol); +} + bool IsExplicitlyImpureProcedure(const Symbol &original) { // An ENTRY is IMPURE if its containing subprogram is so return DEREF(GetMainEntry(&original.GetUltimate())) @@ -2178,7 +2193,7 @@ bool IsAutomatic(const Symbol &original) { const Symbol &symbol{original.GetUltimate()}; if (const auto *object{symbol.detailsIf()}) { if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) { - if (const DeclTypeSpec * type{symbol.GetType()}) { + if (const DeclTypeSpec *type{symbol.GetType()}) { // If a type parameter value is not a constant expression, the // object is automatic. if (type->category() == DeclTypeSpec::Character) { @@ -2188,7 +2203,7 @@ bool IsAutomatic(const Symbol &original) { return true; } } - } else if (const DerivedTypeSpec * derived{type->AsDerived()}) { + } else if (const DerivedTypeSpec *derived{type->AsDerived()}) { for (const auto &pair : derived->parameters()) { if (const auto &value{pair.second.GetExplicit()}) { if (!evaluate::IsConstantExpr(*value)) { @@ -2513,7 +2528,7 @@ common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) { common::IgnoreTKRSet result; if (const auto *object{symbol.detailsIf()}) { result = object->ignoreTKR(); - if (const Symbol * ownerSymbol{symbol.owner().symbol()}) { + if (const Symbol *ownerSymbol{symbol.owner().symbol()}) { if (const auto *ownerSubp{ownerSymbol->detailsIf()}) { if (ownerSubp->defaultIgnoreTKR()) { result |= common::ignoreTKRAll; @@ -2527,7 +2542,7 @@ common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) { std::optional GetDummyArgumentNumber(const Symbol *symbol) { if (symbol) { if (IsDummy(*symbol)) { - if (const Symbol * subpSym{symbol->owner().symbol()}) { + if (const Symbol *subpSym{symbol->owner().symbol()}) { if (const auto *subp{subpSym->detailsIf()}) { int j{0}; for (const Symbol *dummy : subp->dummyArgs()) { @@ -2552,12 +2567,12 @@ const Symbol *FindAncestorModuleProcedure(const Symbol *symInSubmodule) { nameDetails && nameDetails->kind() == semantics::SubprogramKind::Module) { const Symbol *next{symInSubmodule->owner().symbol()}; - while (const Symbol * submodSym{next}) { + while (const Symbol *submodSym{next}) { next = nullptr; if (const auto *modDetails{ submodSym->detailsIf()}; modDetails && modDetails->isSubmodule() && modDetails->scope()) { - if (const semantics::Scope & parent{modDetails->scope()->parent()}; + if (const semantics::Scope &parent{modDetails->scope()->parent()}; parent.IsSubmodule() || parent.IsModule()) { if (auto iter{parent.find(symInSubmodule->name())}; iter != parent.end()) { diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp index 5f4e62ffdbbf2..7debce6da51b7 100644 --- a/flang/lib/Parser/program-parsers.cpp +++ b/flang/lib/Parser/program-parsers.cpp @@ -524,7 +524,7 @@ TYPE_PARSER(construct(star >> label)) // R1527 prefix-spec -> // declaration-type-spec | ELEMENTAL | IMPURE | MODULE | -// NON_RECURSIVE | PURE | RECURSIVE | +// NON_RECURSIVE | PURE | SIMPLE | RECURSIVE | // (CUDA) ATTRIBUTES ( (DEVICE | GLOBAL | GRID_GLOBAL | HOST)... ) | // LAUNCH_BOUNDS(expr-list) | CLUSTER_DIMS(expr-list) TYPE_PARSER(first("DEVICE" >> pure(common::CUDASubprogramAttrs::Device), @@ -539,6 +539,7 @@ TYPE_PARSER(first(construct(declarationTypeSpec), construct("NON_RECURSIVE"_tok)), construct(construct("PURE"_tok)), construct(construct("RECURSIVE"_tok)), + construct(construct("SIMPLE"_tok)), extension( construct(construct("ATTRIBUTES" >> parenthesized( diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp index dc6d33607146b..d59cb01fe4bcb 100644 --- a/flang/lib/Parser/unparse.cpp +++ b/flang/lib/Parser/unparse.cpp @@ -1761,6 +1761,7 @@ class UnparseVisitor { void Post(const PrefixSpec::Non_Recursive) { Word("NON_RECURSIVE"); } void Post(const PrefixSpec::Pure) { Word("PURE"); } void Post(const PrefixSpec::Recursive) { Word("RECURSIVE"); } + void Post(const PrefixSpec::Simple) { Word("SIMPLE"); } void Unparse(const PrefixSpec::Attributes &x) { Word("ATTRIBUTES("), Walk(x.v), Word(")"); } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 077bee930675e..dbb0c172cb473 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -266,6 +266,7 @@ class AttrsVisitor : public virtual BaseVisitor { HANDLE_ATTR_CLASS(PrefixSpec::Non_Recursive, NON_RECURSIVE) HANDLE_ATTR_CLASS(PrefixSpec::Pure, PURE) HANDLE_ATTR_CLASS(PrefixSpec::Recursive, RECURSIVE) + HANDLE_ATTR_CLASS(PrefixSpec::Simple, SIMPLE) HANDLE_ATTR_CLASS(TypeAttrSpec::BindC, BIND_C) HANDLE_ATTR_CLASS(BindAttr::Deferred, DEFERRED) HANDLE_ATTR_CLASS(BindAttr::Non_Overridable, NON_OVERRIDABLE) @@ -2325,7 +2326,7 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) { } symbol.SetBindName(std::move(*label)); if (!oldBindName.empty()) { - if (const std::string * newBindName{symbol.GetBindName()}) { + if (const std::string *newBindName{symbol.GetBindName()}) { if (oldBindName != *newBindName) { Say(symbol.name(), "The entity '%s' has multiple BIND names ('%s' and '%s')"_err_en_US, @@ -2448,7 +2449,7 @@ void DeclTypeSpecVisitor::Post(const parser::TypeSpec &typeSpec) { // expression semantics if the DeclTypeSpec is a valid TypeSpec. // The grammar ensures that it's an intrinsic or derived type spec, // not TYPE(*) or CLASS(*) or CLASS(T). - if (const DeclTypeSpec * spec{state_.declTypeSpec}) { + if (const DeclTypeSpec *spec{state_.declTypeSpec}) { switch (spec->category()) { case DeclTypeSpec::Numeric: case DeclTypeSpec::Logical: @@ -2456,7 +2457,7 @@ void DeclTypeSpecVisitor::Post(const parser::TypeSpec &typeSpec) { typeSpec.declTypeSpec = spec; break; case DeclTypeSpec::TypeDerived: - if (const DerivedTypeSpec * derived{spec->AsDerived()}) { + if (const DerivedTypeSpec *derived{spec->AsDerived()}) { CheckForAbstractType(derived->typeSymbol()); // C703 typeSpec.declTypeSpec = spec; } @@ -3024,8 +3025,8 @@ Symbol &ScopeHandler::MakeSymbol(const parser::Name &name, Attrs attrs) { Symbol &ScopeHandler::MakeHostAssocSymbol( const parser::Name &name, const Symbol &hostSymbol) { Symbol &symbol{*NonDerivedTypeScope() - .try_emplace(name.source, HostAssocDetails{hostSymbol}) - .first->second}; + .try_emplace(name.source, HostAssocDetails{hostSymbol}) + .first->second}; name.symbol = &symbol; symbol.attrs() = hostSymbol.attrs(); // TODO: except PRIVATE, PUBLIC? // These attributes can be redundantly reapplied without error @@ -3113,7 +3114,7 @@ void ScopeHandler::ApplyImplicitRules( if (context().HasError(symbol) || !NeedsType(symbol)) { return; } - if (const DeclTypeSpec * type{GetImplicitType(symbol)}) { + if (const DeclTypeSpec *type{GetImplicitType(symbol)}) { if (!skipImplicitTyping_) { symbol.set(Symbol::Flag::Implicit); symbol.SetType(*type); @@ -3213,7 +3214,7 @@ const DeclTypeSpec *ScopeHandler::GetImplicitType( const auto *type{implicitRulesMap_->at(scope).GetType( symbol.name(), respectImplicitNoneType)}; if (type) { - if (const DerivedTypeSpec * derived{type->AsDerived()}) { + if (const DerivedTypeSpec *derived{type->AsDerived()}) { // Resolve any forward-referenced derived type; a quick no-op else. auto &instantiatable{*const_cast(derived)}; instantiatable.Instantiate(currScope()); @@ -3928,10 +3929,10 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, } else if (IsPointer(p1) || IsPointer(p2)) { return false; } else if (const auto *subp{p1.detailsIf()}; - subp && !subp->isInterface()) { + subp && !subp->isInterface()) { return false; // defined in module, not an external } else if (const auto *subp{p2.detailsIf()}; - subp && !subp->isInterface()) { + subp && !subp->isInterface()) { return false; // defined in module, not an external } else { // Both are external interfaces, perhaps to the same procedure @@ -4191,7 +4192,7 @@ Scope *ModuleVisitor::FindModule(const parser::Name &name, if (scope) { if (DoesScopeContain(scope, currScope())) { // 14.2.2(1) std::optional submoduleName; - if (const Scope * container{FindModuleOrSubmoduleContaining(currScope())}; + if (const Scope *container{FindModuleOrSubmoduleContaining(currScope())}; container && container->IsSubmodule()) { submoduleName = container->GetName(); } @@ -4296,7 +4297,7 @@ bool InterfaceVisitor::isAbstract() const { void InterfaceVisitor::AddSpecificProcs( const std::list &names, ProcedureKind kind) { - if (Symbol * symbol{GetGenericInfo().symbol}; + if (Symbol *symbol{GetGenericInfo().symbol}; symbol && symbol->has()) { for (const auto &name : names) { specificsForGenericProcs_.emplace(symbol, std::make_pair(&name, kind)); @@ -4396,7 +4397,7 @@ void GenericHandler::DeclaredPossibleSpecificProc(Symbol &proc) { } void InterfaceVisitor::ResolveNewSpecifics() { - if (Symbol * generic{genericInfo_.top().symbol}; + if (Symbol *generic{genericInfo_.top().symbol}; generic && generic->has()) { ResolveSpecificsInGeneric(*generic, false); } @@ -4481,7 +4482,7 @@ bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) { name.source); MakeSymbol(name, Attrs{}, UnknownDetails{}); } else if (auto *entity{ultimate.detailsIf()}; - entity && !ultimate.has()) { + entity && !ultimate.has()) { resultType = entity->type(); ultimate.details() = UnknownDetails{}; // will be replaced below } else { @@ -4537,7 +4538,7 @@ bool SubprogramVisitor::Pre(const parser::Suffix &suffix) { } else { Message &msg{Say(*suffix.resultName, "RESULT(%s) may appear only in a function"_err_en_US)}; - if (const Symbol * subprogram{InclusiveScope().symbol()}) { + if (const Symbol *subprogram{InclusiveScope().symbol()}) { msg.Attach(subprogram->name(), "Containing subprogram"_en_US); } } @@ -5053,7 +5054,7 @@ Symbol *ScopeHandler::FindSeparateModuleProcedureInterface( symbol = generic->specific(); } } - if (const Symbol * defnIface{FindSeparateModuleSubprogramInterface(symbol)}) { + if (const Symbol *defnIface{FindSeparateModuleSubprogramInterface(symbol)}) { // Error recovery in case of multiple definitions symbol = const_cast(defnIface); } @@ -5189,8 +5190,8 @@ bool SubprogramVisitor::HandlePreviousCalls( return generic->specific() && HandlePreviousCalls(name, *generic->specific(), subpFlag); } else if (const auto *proc{symbol.detailsIf()}; proc && - !proc->isDummy() && - !symbol.attrs().HasAny(Attrs{Attr::INTRINSIC, Attr::POINTER})) { + !proc->isDummy() && + !symbol.attrs().HasAny(Attrs{Attr::INTRINSIC, Attr::POINTER})) { // There's a symbol created for previous calls to this subprogram or // ENTRY's name. We have to replace that symbol in situ to avoid the // obligation to rewrite symbol pointers in the parse tree. @@ -5232,7 +5233,7 @@ const Symbol *SubprogramVisitor::CheckExtantProc( if (prev) { if (IsDummy(*prev)) { } else if (auto *entity{prev->detailsIf()}; - IsPointer(*prev) && entity && !entity->type()) { + IsPointer(*prev) && entity && !entity->type()) { // POINTER attribute set before interface } else if (inInterfaceBlock() && currScope() != prev->owner()) { // Procedures in an INTERFACE block do not resolve to symbols @@ -5302,7 +5303,7 @@ Symbol &SubprogramVisitor::PushSubprogramScope(const parser::Name &name, } set_inheritFromParent(false); // interfaces don't inherit, even if MODULE } - if (Symbol * found{FindSymbol(name)}; + if (Symbol *found{FindSymbol(name)}; found && found->has()) { found->set(subpFlag); // PushScope() created symbol } @@ -6149,9 +6150,9 @@ void DeclarationVisitor::Post(const parser::VectorTypeSpec &x) { vectorDerivedType.CookParameters(GetFoldingContext()); } - if (const DeclTypeSpec * - extant{ppcBuiltinTypesScope->FindInstantiatedDerivedType( - vectorDerivedType, DeclTypeSpec::Category::TypeDerived)}) { + if (const DeclTypeSpec *extant{ + ppcBuiltinTypesScope->FindInstantiatedDerivedType( + vectorDerivedType, DeclTypeSpec::Category::TypeDerived)}) { // This derived type and parameter expressions (if any) are already present // in the __ppc_intrinsics scope. SetDeclTypeSpec(*extant); @@ -6173,7 +6174,7 @@ bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Type &) { void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Type &type) { const parser::Name &derivedName{std::get(type.derived.t)}; - if (const Symbol * derivedSymbol{derivedName.symbol}) { + if (const Symbol *derivedSymbol{derivedName.symbol}) { CheckForAbstractType(*derivedSymbol); // C706 } } @@ -6242,8 +6243,8 @@ void DeclarationVisitor::Post(const parser::DerivedTypeSpec &x) { if (!spec->MightBeParameterized()) { spec->EvaluateParameters(context()); } - if (const DeclTypeSpec * - extant{currScope().FindInstantiatedDerivedType(*spec, category)}) { + if (const DeclTypeSpec *extant{ + currScope().FindInstantiatedDerivedType(*spec, category)}) { // This derived type and parameter expressions (if any) are already present // in this scope. SetDeclTypeSpec(*extant); @@ -6274,8 +6275,7 @@ void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Record &rec) { if (auto spec{ResolveDerivedType(typeName)}) { spec->CookParameters(GetFoldingContext()); spec->EvaluateParameters(context()); - if (const DeclTypeSpec * - extant{currScope().FindInstantiatedDerivedType( + if (const DeclTypeSpec *extant{currScope().FindInstantiatedDerivedType( *spec, DeclTypeSpec::TypeDerived)}) { SetDeclTypeSpec(*extant); } else { @@ -7195,7 +7195,7 @@ void DeclarationVisitor::CheckCommonBlocks() { } else if (symbol->IsFuncResult()) { Say(name, "Function result '%s' may not appear in a COMMON block"_err_en_US); - } else if (const DeclTypeSpec * type{symbol->GetType()}) { + } else if (const DeclTypeSpec *type{symbol->GetType()}) { if (type->category() == DeclTypeSpec::ClassStar) { Say(name, "Unlimited polymorphic pointer '%s' may not appear in a COMMON block"_err_en_US); @@ -7348,7 +7348,7 @@ bool DeclarationVisitor::PassesLocalityChecks( "Coarray '%s' not allowed in a %s locality-spec"_err_en_US, specName); return false; } - if (const DeclTypeSpec * type{symbol.GetType()}) { + if (const DeclTypeSpec *type{symbol.GetType()}) { if (type->IsPolymorphic() && IsDummy(symbol) && !IsPointer(symbol) && !isReduce) { // F'2023 C1130 SayWithDecl(name, symbol, @@ -7575,7 +7575,7 @@ Symbol *DeclarationVisitor::NoteInterfaceName(const parser::Name &name) { } void DeclarationVisitor::CheckExplicitInterface(const parser::Name &name) { - if (const Symbol * symbol{name.symbol}) { + if (const Symbol *symbol{name.symbol}) { const Symbol &ultimate{symbol->GetUltimate()}; if (!context().HasError(*symbol) && !context().HasError(ultimate) && !BypassGeneric(ultimate).HasExplicitInterface()) { @@ -7893,7 +7893,7 @@ bool ConstructVisitor::Pre(const parser::DataStmtValue &x) { auto &mutableData{const_cast(data)}; if (auto *elem{parser::Unwrap(mutableData)}) { if (const auto *name{std::get_if(&elem->base.u)}) { - if (const Symbol * symbol{FindSymbol(*name)}; + if (const Symbol *symbol{FindSymbol(*name)}; symbol && symbol->GetUltimate().has()) { mutableData.u = elem->ConvertToStructureConstructor( DerivedTypeSpec{name->source, *symbol}); @@ -8039,15 +8039,15 @@ void ConstructVisitor::Post(const parser::SelectTypeStmt &x) { } } } else { - if (const Symbol * - whole{UnwrapWholeSymbolDataRef(association.selector.expr)}) { + if (const Symbol *whole{ + UnwrapWholeSymbolDataRef(association.selector.expr)}) { ConvertToObjectEntity(const_cast(*whole)); if (!IsVariableName(*whole)) { Say(association.selector.source, // C901 "Selector is not a variable"_err_en_US); association = {}; } - if (const DeclTypeSpec * type{whole->GetType()}) { + if (const DeclTypeSpec *type{whole->GetType()}) { if (!type->IsPolymorphic()) { // C1159 Say(association.selector.source, "Selector '%s' in SELECT TYPE statement must be " @@ -8187,8 +8187,8 @@ Symbol *ConstructVisitor::MakeAssocEntity() { "The associate name '%s' is already used in this associate statement"_err_en_US); return nullptr; } - } else if (const Symbol * - whole{UnwrapWholeSymbolDataRef(association.selector.expr)}) { + } else if (const Symbol *whole{ + UnwrapWholeSymbolDataRef(association.selector.expr)}) { symbol = &MakeSymbol(whole->name()); } else { return nullptr; @@ -8810,7 +8810,7 @@ bool DeclarationVisitor::CheckForHostAssociatedImplicit( if (name.symbol) { ApplyImplicitRules(*name.symbol, true); } - if (Scope * host{GetHostProcedure()}; host && !isImplicitNoneType(*host)) { + if (Scope *host{GetHostProcedure()}; host && !isImplicitNoneType(*host)) { Symbol *hostSymbol{nullptr}; if (!name.symbol) { if (currScope().CanImport(name.source)) { @@ -8881,7 +8881,7 @@ const parser::Name *DeclarationVisitor::FindComponent( if (!type) { return nullptr; // should have already reported error } - if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) { + if (const IntrinsicTypeSpec *intrinsic{type->AsIntrinsic()}) { auto category{intrinsic->category()}; MiscDetails::Kind miscKind{MiscDetails::Kind::None}; if (component.source == "kind") { @@ -8903,7 +8903,7 @@ const parser::Name *DeclarationVisitor::FindComponent( } } else if (DerivedTypeSpec * derived{type->AsDerived()}) { derived->Instantiate(currScope()); // in case of forward referenced type - if (const Scope * scope{derived->scope()}) { + if (const Scope *scope{derived->scope()}) { if (Resolve(component, scope->FindComponent(component.source))) { if (auto msg{CheckAccessibleSymbol(currScope(), *component.symbol)}) { context().Say(component.source, *msg); @@ -9051,8 +9051,8 @@ void DeclarationVisitor::PointerInitialization( if (evaluate::IsNullProcedurePointer(&*expr)) { CHECK(!details->init()); details->set_init(nullptr); - } else if (const Symbol * - targetSymbol{evaluate::UnwrapWholeSymbolDataRef(*expr)}) { + } else if (const Symbol *targetSymbol{ + evaluate::UnwrapWholeSymbolDataRef(*expr)}) { CHECK(!details->init()); details->set_init(*targetSymbol); } else { @@ -9571,7 +9571,7 @@ void ResolveNamesVisitor::EarlyDummyTypeDeclaration( for (const auto &ent : entities) { const auto &objName{std::get(ent.t)}; Resolve(objName, FindInScope(currScope(), objName)); - if (Symbol * symbol{objName.symbol}; + if (Symbol *symbol{objName.symbol}; symbol && IsDummy(*symbol) && NeedsType(*symbol)) { if (!type) { type = ProcessTypeSpec(declTypeSpec); @@ -9710,7 +9710,7 @@ void ResolveNamesVisitor::FinishSpecificationPart( if (auto *proc{symbol.detailsIf()}; proc && !proc->isDummy() && !IsPointer(symbol) && !symbol.attrs().test(Attr::BIND_C)) { - if (const Symbol * iface{proc->procInterface()}; + if (const Symbol *iface{proc->procInterface()}; iface && IsBindCProcedure(*iface)) { SetImplicitAttr(symbol, Attr::BIND_C); SetBindNameOn(symbol); @@ -9843,7 +9843,7 @@ bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) { Symbol *ptrSymbol{parser::GetLastName(dataRef).symbol}; Walk(bounds); // Resolve unrestricted specific intrinsic procedures as in "p => cos". - if (const parser::Name * name{parser::Unwrap(expr)}) { + if (const parser::Name *name{parser::Unwrap(expr)}) { if (NameIsKnownOrIntrinsic(*name)) { if (Symbol * symbol{name->symbol}) { if (IsProcedurePointer(ptrSymbol) && @@ -10284,8 +10284,8 @@ void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) { // implied SAVE so that evaluate::IsSaved() will return true. if (node.scope()->kind() == Scope::Kind::MainProgram) { if (const auto *object{symbol.detailsIf()}) { - if (const DeclTypeSpec * type{object->type()}) { - if (const DerivedTypeSpec * derived{type->AsDerived()}) { + if (const DeclTypeSpec *type{object->type()}) { + if (const DerivedTypeSpec *derived{type->AsDerived()}) { if (!IsSaved(symbol) && FindCoarrayPotentialComponent(*derived)) { SetImplicitAttr(symbol, Attr::SAVE); } @@ -10538,7 +10538,7 @@ void ResolveNamesVisitor::FinishDerivedTypeInstantiation(Scope &scope) { if (DerivedTypeSpec * spec{scope.derivedTypeSpec()}) { spec->Instantiate(currScope()); const Symbol &origTypeSymbol{spec->typeSymbol()}; - if (const Scope * origTypeScope{origTypeSymbol.scope()}) { + if (const Scope *origTypeScope{origTypeSymbol.scope()}) { CHECK(origTypeScope->IsDerivedType() && origTypeScope->symbol() == &origTypeSymbol); auto &foldingContext{GetFoldingContext()}; @@ -10549,7 +10549,7 @@ void ResolveNamesVisitor::FinishDerivedTypeInstantiation(Scope &scope) { if (IsPointer(comp)) { if (auto *details{comp.detailsIf()}) { auto origDetails{origComp.get()}; - if (const MaybeExpr & init{origDetails.init()}) { + if (const MaybeExpr &init{origDetails.init()}) { SomeExpr newInit{*init}; MaybeExpr folded{FoldExpr(std::move(newInit))}; details->set_init(std::move(folded)); diff --git a/flang/test/Parser/simple-unparse.f90 b/flang/test/Parser/simple-unparse.f90 new file mode 100644 index 0000000000000..c2b187e329761 --- /dev/null +++ b/flang/test/Parser/simple-unparse.f90 @@ -0,0 +1,13 @@ +! RUN: %flang_fc1 -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s + +! Test that SIMPLE function specifier is recognized +! by the parser and the unparser. This test does not +! exercise semantic checks. + +simple function foo() + return +end function + +! CHECK: SIMPLE FUNCTION foo() +! CHECK-NEXT: RETURN +! CHECK-NEXT: END FUNCTION diff --git a/flang/test/Parser/simple.f90 b/flang/test/Parser/simple.f90 new file mode 100644 index 0000000000000..2959938824395 --- /dev/null +++ b/flang/test/Parser/simple.f90 @@ -0,0 +1,10 @@ +! RUN: %flang_fc1 -fdebug-dump-parse-tree %s | FileCheck %s + +! Check that SIMPLE is recognized in the parse tree + +simple function foo() + return +end function + +! CHECK: Simple + From 353c285b40123dfaa21e25e994cea7df389c13f1 Mon Sep 17 00:00:00 2001 From: Sarka Holendova Date: Fri, 26 Sep 2025 18:48:36 +0200 Subject: [PATCH 2/2] Restore check-expression.cpp --- flang/lib/Evaluate/check-expression.cpp | 1635 +++++++++++++++++++++++ 1 file changed, 1635 insertions(+) create mode 100644 flang/lib/Evaluate/check-expression.cpp diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp new file mode 100644 index 0000000000000..c222bd2c583a0 --- /dev/null +++ b/flang/lib/Evaluate/check-expression.cpp @@ -0,0 +1,1635 @@ +//===-- lib/Evaluate/check-expression.cpp ---------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "flang/Evaluate/check-expression.h" +#include "flang/Evaluate/characteristics.h" +#include "flang/Evaluate/intrinsics.h" +#include "flang/Evaluate/tools.h" +#include "flang/Evaluate/traverse.h" +#include "flang/Evaluate/type.h" +#include "flang/Semantics/semantics.h" +#include "flang/Semantics/symbol.h" +#include "flang/Semantics/tools.h" +#include +#include + +namespace Fortran::evaluate { + +// Constant expression predicates IsConstantExpr() & IsScopeInvariantExpr(). +// This code determines whether an expression is a "constant expression" +// in the sense of section 10.1.12. This is not the same thing as being +// able to fold it (yet) into a known constant value; specifically, +// the expression may reference derived type kind parameters whose values +// are not yet known. +// +// The variant form (IsScopeInvariantExpr()) also accepts symbols that are +// INTENT(IN) dummy arguments without the VALUE attribute. +template +class IsConstantExprHelper + : public AllTraverse, true> { +public: + using Base = AllTraverse; + IsConstantExprHelper() : Base{*this} {} + using Base::operator(); + + // A missing expression is not considered to be constant. + template bool operator()(const std::optional &x) const { + return x && (*this)(*x); + } + + bool operator()(const TypeParamInquiry &inq) const { + return INVARIANT || semantics::IsKindTypeParameter(inq.parameter()); + } + bool operator()(const semantics::Symbol &symbol) const { + const auto &ultimate{GetAssociationRoot(symbol)}; + return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) || + IsInitialProcedureTarget(ultimate) || + ultimate.has() || + (INVARIANT && IsIntentIn(symbol) && !IsOptional(symbol) && + !symbol.attrs().test(semantics::Attr::VALUE)); + } + bool operator()(const CoarrayRef &) const { return false; } + bool operator()(const semantics::ParamValue ¶m) const { + return param.isExplicit() && (*this)(param.GetExplicit()); + } + bool operator()(const ProcedureRef &) const; + bool operator()(const StructureConstructor &constructor) const { + for (const auto &[symRef, expr] : constructor) { + if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) { + return false; + } + } + return true; + } + bool operator()(const Component &component) const { + return (*this)(component.base()); + } + // Prevent integer division by known zeroes in constant expressions. + template + bool operator()( + const Divide> &division) const { + using T = Type; + if ((*this)(division.left()) && (*this)(division.right())) { + const auto divisor{GetScalarConstantValue(division.right())}; + return !divisor || !divisor->IsZero(); + } else { + return false; + } + } + + bool operator()(const Constant &) const { return true; } + bool operator()(const DescriptorInquiry &x) const { + const Symbol &sym{x.base().GetLastSymbol()}; + return INVARIANT && !IsAllocatable(sym) && + (!IsDummy(sym) || + (IsIntentIn(sym) && !IsOptional(sym) && + !sym.attrs().test(semantics::Attr::VALUE))); + } + +private: + bool IsConstantStructureConstructorComponent( + const Symbol &, const Expr &) const; + bool IsConstantExprShape(const Shape &) const; +}; + +template +bool IsConstantExprHelper::IsConstantStructureConstructorComponent( + const Symbol &component, const Expr &expr) const { + if (IsAllocatable(component)) { + return IsNullObjectPointer(&expr); + } else if (IsPointer(component)) { + return IsNullPointerOrAllocatable(&expr) || IsInitialDataTarget(expr) || + IsInitialProcedureTarget(expr); + } else { + return (*this)(expr); + } +} + +template +bool IsConstantExprHelper::operator()( + const ProcedureRef &call) const { + // LBOUND, UBOUND, and SIZE with truly constant DIM= arguments will have + // been rewritten into DescriptorInquiry operations. + if (const auto *intrinsic{std::get_if(&call.proc().u)}) { + const characteristics::Procedure &proc{intrinsic->characteristics.value()}; + if (intrinsic->name == "kind" || + intrinsic->name == IntrinsicProcTable::InvalidName || + call.arguments().empty() || !call.arguments()[0]) { + // kind is always a constant, and we avoid cascading errors by considering + // invalid calls to intrinsics to be constant + return true; + } else if (intrinsic->name == "lbound") { + auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())}; + return base && IsConstantExprShape(GetLBOUNDs(*base)); + } else if (intrinsic->name == "ubound") { + auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())}; + return base && IsConstantExprShape(GetUBOUNDs(*base)); + } else if (intrinsic->name == "shape" || intrinsic->name == "size") { + auto shape{GetShape(call.arguments()[0]->UnwrapExpr())}; + return shape && IsConstantExprShape(*shape); + } else if (proc.IsPure()) { + std::size_t j{0}; + for (const auto &arg : call.arguments()) { + if (const auto *dataDummy{j < proc.dummyArguments.size() + ? std::get_if( + &proc.dummyArguments[j].u) + : nullptr}; + dataDummy && + dataDummy->attrs.test( + characteristics::DummyDataObject::Attr::OnlyIntrinsicInquiry)) { + // The value of the argument doesn't matter + } else if (!arg) { + return false; + } else if (const auto *expr{arg->UnwrapExpr()}; + !expr || !(*this)(*expr)) { + return false; + } + ++j; + } + return true; + } + // TODO: STORAGE_SIZE + } + return false; +} + +template +bool IsConstantExprHelper::IsConstantExprShape( + const Shape &shape) const { + for (const auto &extent : shape) { + if (!(*this)(extent)) { + return false; + } + } + return true; +} + +template bool IsConstantExpr(const A &x) { + return IsConstantExprHelper{}(x); +} +template bool IsConstantExpr(const Expr &); +template bool IsConstantExpr(const Expr &); +template bool IsConstantExpr(const Expr &); +template bool IsConstantExpr(const StructureConstructor &); + +// IsScopeInvariantExpr() +template bool IsScopeInvariantExpr(const A &x) { + return IsConstantExprHelper{}(x); +} +template bool IsScopeInvariantExpr(const Expr &); +template bool IsScopeInvariantExpr(const Expr &); +template bool IsScopeInvariantExpr(const Expr &); + +// IsActuallyConstant() +struct IsActuallyConstantHelper { + template bool operator()(const A &) { return false; } + template bool operator()(const Constant &) { return true; } + template bool operator()(const Parentheses &x) { + return (*this)(x.left()); + } + template bool operator()(const Expr &x) { + return common::visit([=](const auto &y) { return (*this)(y); }, x.u); + } + bool operator()(const Expr &x) { + return common::visit([this](const auto &y) { return (*this)(y); }, x.u); + } + bool operator()(const StructureConstructor &x) { + for (const auto &pair : x) { + const Expr &y{pair.second.value()}; + const auto sym{pair.first}; + const bool compIsConstant{(*this)(y)}; + // If an allocatable component is initialized by a constant, + // the structure constructor is not a constant. + if ((!compIsConstant && !IsNullPointerOrAllocatable(&y)) || + (compIsConstant && IsAllocatable(sym))) { + return false; + } + } + return true; + } + template bool operator()(const A *x) { return x && (*this)(*x); } + template bool operator()(const std::optional &x) { + return x && (*this)(*x); + } +}; + +template bool IsActuallyConstant(const A &x) { + return IsActuallyConstantHelper{}(x); +} + +template bool IsActuallyConstant(const Expr &); +template bool IsActuallyConstant(const Expr &); +template bool IsActuallyConstant(const Expr &); +template bool IsActuallyConstant(const std::optional> &); + +// Object pointer initialization checking predicate IsInitialDataTarget(). +// This code determines whether an expression is allowable as the static +// data address used to initialize a pointer with "=> x". See C765. +class IsInitialDataTargetHelper + : public AllTraverse { +public: + using Base = AllTraverse; + using Base::operator(); + explicit IsInitialDataTargetHelper(parser::ContextualMessages *m) + : Base{*this}, messages_{m} {} + + bool emittedMessage() const { return emittedMessage_; } + + bool operator()(const BOZLiteralConstant &) const { return false; } + bool operator()(const NullPointer &) const { return true; } + template bool operator()(const Constant &) const { + return false; + } + bool operator()(const semantics::Symbol &symbol) { + // This function checks only base symbols, not components. + const Symbol &ultimate{symbol.GetUltimate()}; + if (const auto *assoc{ + ultimate.detailsIf()}) { + if (const auto &expr{assoc->expr()}) { + if (IsVariable(*expr)) { + return (*this)(*expr); + } else if (messages_) { + messages_->Say( + "An initial data target may not be an associated expression ('%s')"_err_en_US, + ultimate.name()); + emittedMessage_ = true; + } + } + return false; + } else if (!CheckVarOrComponent(ultimate)) { + return false; + } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) { + if (messages_) { + messages_->Say( + "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US, + ultimate.name()); + emittedMessage_ = true; + } + return false; + } else if (!IsSaved(ultimate)) { + if (messages_) { + messages_->Say( + "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US, + ultimate.name()); + emittedMessage_ = true; + } + return false; + } else { + return true; + } + } + bool operator()(const StaticDataObject &) const { return false; } + bool operator()(const TypeParamInquiry &) const { return false; } + bool operator()(const Triplet &x) const { + return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) && + IsConstantExpr(x.stride()); + } + bool operator()(const Subscript &x) const { + return common::visit(common::visitors{ + [&](const Triplet &t) { return (*this)(t); }, + [&](const auto &y) { + return y.value().Rank() == 0 && + IsConstantExpr(y.value()); + }, + }, + x.u); + } + bool operator()(const CoarrayRef &) const { return false; } + bool operator()(const Component &x) { + return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base()); + } + bool operator()(const Substring &x) const { + return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) && + (*this)(x.parent()); + } + bool operator()(const DescriptorInquiry &) const { return false; } + template bool operator()(const ArrayConstructor &) const { + return false; + } + bool operator()(const StructureConstructor &) const { return false; } + template + bool operator()(const Operation &) const { + return false; + } + template bool operator()(const Parentheses &x) const { + return (*this)(x.left()); + } + bool operator()(const ProcedureRef &x) const { + if (const SpecificIntrinsic *intrinsic{x.proc().GetSpecificIntrinsic()}) { + return intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullPointer) || + intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullAllocatable); + } + return false; + } + bool operator()(const Relational &) const { return false; } + +private: + bool CheckVarOrComponent(const semantics::Symbol &symbol) { + const Symbol &ultimate{symbol.GetUltimate()}; + const char *unacceptable{nullptr}; + if (ultimate.Corank() > 0) { + unacceptable = "a coarray"; + } else if (IsAllocatable(ultimate)) { + unacceptable = "an ALLOCATABLE"; + } else if (IsPointer(ultimate)) { + unacceptable = "a POINTER"; + } else { + return true; + } + if (messages_) { + messages_->Say( + "An initial data target may not be a reference to %s '%s'"_err_en_US, + unacceptable, ultimate.name()); + emittedMessage_ = true; + } + return false; + } + + parser::ContextualMessages *messages_; + bool emittedMessage_{false}; +}; + +bool IsInitialDataTarget( + const Expr &x, parser::ContextualMessages *messages) { + IsInitialDataTargetHelper helper{messages}; + bool result{helper(x)}; + if (!result && messages && !helper.emittedMessage()) { + messages->Say( + "An initial data target must be a designator with constant subscripts"_err_en_US); + } + return result; +} + +bool IsInitialProcedureTarget(const semantics::Symbol &symbol) { + const auto &ultimate{symbol.GetUltimate()}; + return common::visit( + common::visitors{ + [&](const semantics::SubprogramDetails &subp) { + return !subp.isDummy() && !subp.stmtFunction() && + symbol.owner().kind() != semantics::Scope::Kind::MainProgram && + symbol.owner().kind() != semantics::Scope::Kind::Subprogram; + }, + [](const semantics::SubprogramNameDetails &x) { + return x.kind() != semantics::SubprogramKind::Internal; + }, + [&](const semantics::ProcEntityDetails &proc) { + return !semantics::IsPointer(ultimate) && !proc.isDummy(); + }, + [](const auto &) { return false; }, + }, + ultimate.details()); +} + +bool IsInitialProcedureTarget(const ProcedureDesignator &proc) { + if (const auto *intrin{proc.GetSpecificIntrinsic()}) { + return !intrin->isRestrictedSpecific; + } else if (proc.GetComponent()) { + return false; + } else { + return IsInitialProcedureTarget(DEREF(proc.GetSymbol())); + } +} + +bool IsInitialProcedureTarget(const Expr &expr) { + if (const auto *proc{std::get_if(&expr.u)}) { + return IsInitialProcedureTarget(*proc); + } else { + return IsNullProcedurePointer(&expr); + } +} + +class SuspiciousRealLiteralFinder + : public AnyTraverse { +public: + using Base = AnyTraverse; + SuspiciousRealLiteralFinder(int kind, FoldingContext &c) + : Base{*this}, kind_{kind}, context_{c} {} + using Base::operator(); + template + bool operator()(const Constant> &x) const { + if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) { + context_.Warn(common::UsageWarning::RealConstantWidening, + "Default real literal in REAL(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US, + kind_, x.AsFortran()); + return true; + } else { + return false; + } + } + template + bool operator()(const Constant> &x) const { + if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) { + context_.Warn(common::UsageWarning::RealConstantWidening, + "Default real literal in COMPLEX(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US, + kind_, x.AsFortran()); + return true; + } else { + return false; + } + } + template + bool operator()(const Convert, FROMCAT> &x) const { + if constexpr ((TOCAT == TypeCategory::Real || + TOCAT == TypeCategory::Complex) && + (FROMCAT == TypeCategory::Real || FROMCAT == TypeCategory::Complex)) { + auto fromType{x.left().GetType()}; + if (!fromType || fromType->kind() < TOKIND) { + return false; + } + } + return (*this)(x.left()); + } + +private: + int kind_; + FoldingContext &context_; +}; + +void CheckRealWidening(const Expr &expr, const DynamicType &toType, + FoldingContext &context) { + if (toType.category() == TypeCategory::Real || + toType.category() == TypeCategory::Complex) { + if (auto fromType{expr.GetType()}) { + if ((fromType->category() == TypeCategory::Real || + fromType->category() == TypeCategory::Complex) && + toType.kind() > fromType->kind()) { + SuspiciousRealLiteralFinder{toType.kind(), context}(expr); + } + } + } +} + +void CheckRealWidening(const Expr &expr, + const std::optional &toType, FoldingContext &context) { + if (toType) { + CheckRealWidening(expr, *toType, context); + } +} + +class InexactLiteralConversionFlagClearer + : public AnyTraverse { +public: + using Base = AnyTraverse; + InexactLiteralConversionFlagClearer() : Base(*this) {} + using Base::operator(); + template + bool operator()(const Constant> &x) const { + auto &mut{const_cast &>(x.result())}; + mut.set_isFromInexactLiteralConversion(false); + return false; + } +}; + +// Converts, folds, and then checks type, rank, and shape of an +// initialization expression for a named constant, a non-pointer +// variable static initialization, a component default initializer, +// a type parameter default value, or instantiated type parameter value. +std::optional> NonPointerInitializationExpr(const Symbol &symbol, + Expr &&x, FoldingContext &context, + const semantics::Scope *instantiation) { + CHECK(!IsPointer(symbol)); + if (auto symTS{ + characteristics::TypeAndShape::Characterize(symbol, context)}) { + auto xType{x.GetType()}; + CheckRealWidening(x, symTS->type(), context); + auto converted{ConvertToType(symTS->type(), Expr{x})}; + if (!converted && + symbol.owner().context().IsEnabled( + common::LanguageFeature::LogicalIntegerAssignment)) { + converted = DataConstantConversionExtension(context, symTS->type(), x); + if (converted) { + context.Warn(common::LanguageFeature::LogicalIntegerAssignment, + "nonstandard usage: initialization of %s with %s"_port_en_US, + symTS->type().AsFortran(), x.GetType().value().AsFortran()); + } + } + if (converted) { + auto folded{Fold(context, std::move(*converted))}; + if (IsActuallyConstant(folded)) { + InexactLiteralConversionFlagClearer{}(folded); + int symRank{symTS->Rank()}; + if (IsImpliedShape(symbol)) { + if (folded.Rank() == symRank) { + return ArrayConstantBoundChanger{ + std::move(*AsConstantExtents( + context, GetRawLowerBounds(context, NamedEntity{symbol})))} + .ChangeLbounds(std::move(folded)); + } else { + context.messages().Say( + "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US, + symbol.name(), symRank, folded.Rank()); + } + } else if (auto extents{AsConstantExtents(context, symTS->shape())}; + extents && !HasNegativeExtent(*extents)) { + if (folded.Rank() == 0 && symRank == 0) { + // symbol and constant are both scalars + return {std::move(folded)}; + } else if (folded.Rank() == 0 && symRank > 0) { + // expand the scalar constant to an array + return ScalarConstantExpander{std::move(*extents), + AsConstantExtents( + context, GetRawLowerBounds(context, NamedEntity{symbol}))} + .Expand(std::move(folded)); + } else if (auto resultShape{GetShape(context, folded)}) { + CHECK(symTS->shape()); // Assumed-ranks cannot be initialized. + if (CheckConformance(context.messages(), *symTS->shape(), + *resultShape, CheckConformanceFlags::None, + "initialized object", "initialization expression") + .value_or(false /*fail if not known now to conform*/)) { + // make a constant array with adjusted lower bounds + return ArrayConstantBoundChanger{ + std::move(*AsConstantExtents(context, + GetRawLowerBounds(context, NamedEntity{symbol})))} + .ChangeLbounds(std::move(folded)); + } + } + } else if (IsNamedConstant(symbol)) { + if (IsExplicitShape(symbol)) { + context.messages().Say( + "Named constant '%s' array must have constant shape"_err_en_US, + symbol.name()); + } else { + // Declaration checking handles other cases + } + } else { + context.messages().Say( + "Shape of initialized object '%s' must be constant"_err_en_US, + symbol.name()); + } + } else if (IsErrorExpr(folded)) { + } else if (IsLenTypeParameter(symbol)) { + return {std::move(folded)}; + } else if (IsKindTypeParameter(symbol)) { + if (instantiation) { + context.messages().Say( + "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US, + symbol.name(), folded.AsFortran()); + } else { + return {std::move(folded)}; + } + } else if (IsNamedConstant(symbol)) { + if (symbol.name() == "numeric_storage_size" && + symbol.owner().IsModule() && + DEREF(symbol.owner().symbol()).name() == "iso_fortran_env") { + // Very special case: numeric_storage_size is not folded until + // it read from the iso_fortran_env module file, as its value + // depends on compilation options. + return {std::move(folded)}; + } + context.messages().Say( + "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US, + symbol.name(), folded.AsFortran()); + } else { + context.messages().Say( + "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US, + symbol.name(), x.AsFortran()); + } + } else if (xType) { + context.messages().Say( + "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US, + symbol.name(), xType->AsFortran()); + } else { + context.messages().Say( + "Initialization expression cannot be converted to declared type of '%s'"_err_en_US, + symbol.name()); + } + } + return std::nullopt; +} + +// Specification expression validation (10.1.11(2), C1010) +class CheckSpecificationExprHelper + : public AnyTraverse> { +public: + using Result = std::optional; + using Base = AnyTraverse; + explicit CheckSpecificationExprHelper(const semantics::Scope &s, + FoldingContext &context, bool forElementalFunctionResult) + : Base{*this}, scope_{s}, context_{context}, + forElementalFunctionResult_{forElementalFunctionResult} {} + using Base::operator(); + + Result operator()(const CoarrayRef &) const { return "coindexed reference"; } + + Result operator()(const semantics::Symbol &symbol) const { + const auto &ultimate{symbol.GetUltimate()}; + const auto *object{ultimate.detailsIf()}; + bool isInitialized{semantics::IsSaved(ultimate) && + !IsAllocatable(ultimate) && object && + (ultimate.test(Symbol::Flag::InDataStmt) || + object->init().has_value())}; + bool hasHostAssociation{ + &symbol.owner() != &scope_ || &ultimate.owner() != &scope_}; + if (const auto *assoc{ + ultimate.detailsIf()}) { + return (*this)(assoc->expr()); + } else if (semantics::IsNamedConstant(ultimate) || + ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) { + return std::nullopt; + } else if (scope_.IsDerivedType() && + IsVariableName(ultimate)) { // C750, C754 + return "derived type component or type parameter value not allowed to " + "reference variable '"s + + ultimate.name().ToString() + "'"; + } else if (IsDummy(ultimate)) { + if (!inInquiry_ && forElementalFunctionResult_) { + return "dependence on value of dummy argument '"s + + ultimate.name().ToString() + "'"; + } else if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) { + return "reference to OPTIONAL dummy argument '"s + + ultimate.name().ToString() + "'"; + } else if (!inInquiry_ && !hasHostAssociation && + ultimate.attrs().test(semantics::Attr::INTENT_OUT)) { + return "reference to INTENT(OUT) dummy argument '"s + + ultimate.name().ToString() + "'"; + } else if (!ultimate.has()) { + return "dummy procedure argument"; + } else { + // Sketchy case: some compilers allow an INTENT(OUT) dummy argument + // to be used in a specification expression if it is host-associated. + // The arguments raised in support this usage, however, depend on + // a reading of the standard that would also accept an OPTIONAL + // host-associated dummy argument, and that doesn't seem like a + // good idea. + if (!inInquiry_ && hasHostAssociation && + ultimate.attrs().test(semantics::Attr::INTENT_OUT)) { + context_.Warn(common::UsageWarning::HostAssociatedIntentOutInSpecExpr, + "specification expression refers to host-associated INTENT(OUT) dummy argument '%s'"_port_en_US, + ultimate.name()); + } + return std::nullopt; + } + } else if (hasHostAssociation) { + return std::nullopt; // host association is in play + } else if (isInitialized && + context_.languageFeatures().IsEnabled( + common::LanguageFeature::SavedLocalInSpecExpr)) { + context_.Warn(common::LanguageFeature::SavedLocalInSpecExpr, + "specification expression refers to local object '%s' (initialized and saved)"_port_en_US, + ultimate.name()); + return std::nullopt; + } else if (const auto *object{ + ultimate.detailsIf()}) { + if (object->commonBlock()) { + return std::nullopt; + } + } + if (inInquiry_) { + return std::nullopt; + } else { + return "reference to local entity '"s + ultimate.name().ToString() + "'"; + } + } + + Result operator()(const Component &x) const { + // Don't look at the component symbol. + return (*this)(x.base()); + } + Result operator()(const ArrayRef &x) const { + if (auto result{(*this)(x.base())}) { + return result; + } + // The subscripts don't get special protection for being in a + // specification inquiry context; + auto restorer{common::ScopedSet(inInquiry_, false)}; + return (*this)(x.subscript()); + } + Result operator()(const Substring &x) const { + if (auto result{(*this)(x.parent())}) { + return result; + } + // The bounds don't get special protection for being in a + // specification inquiry context; + auto restorer{common::ScopedSet(inInquiry_, false)}; + if (auto result{(*this)(x.lower())}) { + return result; + } + return (*this)(x.upper()); + } + Result operator()(const DescriptorInquiry &x) const { + // Many uses of SIZE(), LBOUND(), &c. that are valid in specification + // expressions will have been converted to expressions over descriptor + // inquiries by Fold(). + // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X)) + if (IsPermissibleInquiry( + x.base().GetFirstSymbol(), x.base().GetLastSymbol(), x.field())) { + auto restorer{common::ScopedSet(inInquiry_, true)}; + return (*this)(x.base()); + } else if (IsConstantExpr(x)) { + return std::nullopt; + } else { + return "non-constant descriptor inquiry not allowed for local object"; + } + } + + Result operator()(const TypeParamInquiry &inq) const { + if (scope_.IsDerivedType()) { + if (!IsConstantExpr(inq) && + inq.base() /* X%T, not local T */) { // C750, C754 + return "non-constant reference to a type parameter inquiry not allowed " + "for derived type components or type parameter values"; + } + } else if (inq.base() && + IsInquiryAlwaysPermissible(inq.base()->GetFirstSymbol())) { + auto restorer{common::ScopedSet(inInquiry_, true)}; + return (*this)(inq.base()); + } else if (!IsConstantExpr(inq)) { + return "non-constant type parameter inquiry not allowed for local object"; + } + return std::nullopt; + } + + Result operator()(const ProcedureRef &x) const { + if (const auto *symbol{x.proc().GetSymbol()}) { + const Symbol &ultimate{symbol->GetUltimate()}; + if (!semantics::IsPureProcedure(ultimate)) { + return "reference to impure function '"s + ultimate.name().ToString() + + "'"; + } + if (semantics::IsStmtFunction(ultimate)) { + return "reference to statement function '"s + + ultimate.name().ToString() + "'"; + } + if (scope_.IsDerivedType()) { // C750, C754 + return "reference to function '"s + ultimate.name().ToString() + + "' not allowed for derived type components or type parameter" + " values"; + } + if (auto procChars{characteristics::Procedure::Characterize( + x.proc(), context_, /*emitError=*/true)}) { + const auto iter{std::find_if(procChars->dummyArguments.begin(), + procChars->dummyArguments.end(), + [](const characteristics::DummyArgument &dummy) { + return std::holds_alternative( + dummy.u); + })}; + if (iter != procChars->dummyArguments.end() && + ultimate.name().ToString() != "__builtin_c_funloc") { + return "reference to function '"s + ultimate.name().ToString() + + "' with dummy procedure argument '" + iter->name + '\''; + } + } + // References to internal functions are caught in expression semantics. + // TODO: other checks for standard module procedures + auto restorer{common::ScopedSet(inInquiry_, false)}; + return (*this)(x.arguments()); + } else { // intrinsic + const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; + bool inInquiry{context_.intrinsics().GetIntrinsicClass(intrin.name) == + IntrinsicClass::inquiryFunction}; + if (scope_.IsDerivedType()) { // C750, C754 + if ((context_.intrinsics().IsIntrinsic(intrin.name) && + badIntrinsicsForComponents_.find(intrin.name) != + badIntrinsicsForComponents_.end())) { + return "reference to intrinsic '"s + intrin.name + + "' not allowed for derived type components or type parameter" + " values"; + } + if (inInquiry && !IsConstantExpr(x)) { + return "non-constant reference to inquiry intrinsic '"s + + intrin.name + + "' not allowed for derived type components or type" + " parameter values"; + } + } + // Type-determined inquiries (DIGITS, HUGE, &c.) will have already been + // folded and won't arrive here. Inquiries that are represented with + // DescriptorInquiry operations (LBOUND) are checked elsewhere. If a + // call that makes it to here satisfies the requirements of a constant + // expression (as Fortran defines it), it's fine. + if (IsConstantExpr(x)) { + return std::nullopt; + } + if (intrin.name == "present") { + return std::nullopt; // always ok + } + const auto &proc{intrin.characteristics.value()}; + std::size_t j{0}; + for (const auto &arg : x.arguments()) { + bool checkArg{true}; + if (const auto *dataDummy{j < proc.dummyArguments.size() + ? std::get_if( + &proc.dummyArguments[j].u) + : nullptr}) { + if (dataDummy->attrs.test(characteristics::DummyDataObject::Attr:: + OnlyIntrinsicInquiry)) { + checkArg = false; // value unused, e.g. IEEE_SUPPORT_FLAG(,,,. X) + } + } + if (arg && checkArg) { + // Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y + if (inInquiry) { + if (auto dataRef{ExtractDataRef(*arg, true, true)}) { + if (intrin.name == "allocated" || intrin.name == "associated" || + intrin.name == "is_contiguous") { // ok + } else if (intrin.name == "len" && + IsPermissibleInquiry(dataRef->GetFirstSymbol(), + dataRef->GetLastSymbol(), + DescriptorInquiry::Field::Len)) { // ok + } else if (intrin.name == "lbound" && + IsPermissibleInquiry(dataRef->GetFirstSymbol(), + dataRef->GetLastSymbol(), + DescriptorInquiry::Field::LowerBound)) { // ok + } else if ((intrin.name == "shape" || intrin.name == "size" || + intrin.name == "sizeof" || + intrin.name == "storage_size" || + intrin.name == "ubound") && + IsPermissibleInquiry(dataRef->GetFirstSymbol(), + dataRef->GetLastSymbol(), + DescriptorInquiry::Field::Extent)) { // ok + } else { + return "non-constant inquiry function '"s + intrin.name + + "' not allowed for local object"; + } + } + } + auto restorer{common::ScopedSet(inInquiry_, inInquiry)}; + if (auto err{(*this)(*arg)}) { + return err; + } + } + ++j; + } + return std::nullopt; + } + } + +private: + const semantics::Scope &scope_; + FoldingContext &context_; + // Contextual information: this flag is true when in an argument to + // an inquiry intrinsic like SIZE(). + mutable bool inInquiry_{false}; + bool forElementalFunctionResult_{false}; // F'2023 C15121 + const std::set badIntrinsicsForComponents_{ + "allocated", "associated", "extends_type_of", "present", "same_type_as"}; + + bool IsInquiryAlwaysPermissible(const semantics::Symbol &) const; + bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol, + const semantics::Symbol &lastSymbol, + DescriptorInquiry::Field field) const; +}; + +bool CheckSpecificationExprHelper::IsInquiryAlwaysPermissible( + const semantics::Symbol &symbol) const { + if (&symbol.owner() != &scope_ || symbol.has() || + symbol.owner().kind() == semantics::Scope::Kind::Module || + semantics::FindCommonBlockContaining(symbol) || + symbol.has()) { + return true; // it's nonlocal + } else if (semantics::IsDummy(symbol) && !forElementalFunctionResult_) { + return true; + } else { + return false; + } +} + +bool CheckSpecificationExprHelper::IsPermissibleInquiry( + const semantics::Symbol &firstSymbol, const semantics::Symbol &lastSymbol, + DescriptorInquiry::Field field) const { + if (IsInquiryAlwaysPermissible(firstSymbol)) { + return true; + } + // Inquiries on local objects may not access a deferred bound or length. + // (This code used to be a switch, but it proved impossible to write it + // thus without running afoul of bogus warnings from different C++ + // compilers.) + if (field == DescriptorInquiry::Field::Rank) { + return true; // always known + } + const auto *object{lastSymbol.detailsIf()}; + if (field == DescriptorInquiry::Field::LowerBound || + field == DescriptorInquiry::Field::Extent || + field == DescriptorInquiry::Field::Stride) { + return object && !object->shape().CanBeDeferredShape(); + } + if (field == DescriptorInquiry::Field::Len) { + return object && object->type() && + object->type()->category() == semantics::DeclTypeSpec::Character && + !object->type()->characterTypeSpec().length().isDeferred(); + } + return false; +} + +template +void CheckSpecificationExpr(const A &x, const semantics::Scope &scope, + FoldingContext &context, bool forElementalFunctionResult) { + CheckSpecificationExprHelper errors{ + scope, context, forElementalFunctionResult}; + if (auto why{errors(x)}) { + context.messages().Say("Invalid specification expression%s: %s"_err_en_US, + forElementalFunctionResult ? " for elemental function result" : "", + *why); + } +} + +template void CheckSpecificationExpr(const Expr &, + const semantics::Scope &, FoldingContext &, + bool forElementalFunctionResult); +template void CheckSpecificationExpr(const Expr &, + const semantics::Scope &, FoldingContext &, + bool forElementalFunctionResult); +template void CheckSpecificationExpr(const Expr &, + const semantics::Scope &, FoldingContext &, + bool forElementalFunctionResult); +template void CheckSpecificationExpr(const std::optional> &, + const semantics::Scope &, FoldingContext &, + bool forElementalFunctionResult); +template void CheckSpecificationExpr(const std::optional> &, + const semantics::Scope &, FoldingContext &, + bool forElementalFunctionResult); +template void CheckSpecificationExpr( + const std::optional> &, const semantics::Scope &, + FoldingContext &, bool forElementalFunctionResult); + +// IsContiguous() -- 9.5.4 +class IsContiguousHelper + : public AnyTraverse> { +public: + using Result = std::optional; // tri-state + using Base = AnyTraverse; + explicit IsContiguousHelper(FoldingContext &c, + bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1 = false) + : Base{*this}, context_{c}, + namedConstantSectionsAreContiguous_{namedConstantSectionsAreContiguous}, + firstDimensionStride1_{firstDimensionStride1} {} + using Base::operator(); + + template Result operator()(const Constant &) const { + return true; + } + Result operator()(const StaticDataObject &) const { return true; } + Result operator()(const semantics::Symbol &symbol) const { + const auto &ultimate{symbol.GetUltimate()}; + if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) { + return true; + } else if (!IsVariable(symbol)) { + return true; + } else if (ultimate.Rank() == 0) { + // Extension: accept scalars as a degenerate case of + // simple contiguity to allow their use in contexts like + // data targets in pointer assignments with remapping. + return true; + } else if (const auto *details{ + ultimate.detailsIf()}) { + // RANK(*) associating entity is contiguous. + if (details->IsAssumedSize()) { + return true; + } else if (!IsVariable(details->expr()) && + (namedConstantSectionsAreContiguous_ || + !ExtractDataRef(details->expr(), true, true))) { + // Selector is associated to an expression value. + return true; + } else { + return Base::operator()(ultimate); // use expr + } + } else if (semantics::IsPointer(ultimate) || IsAssumedShape(ultimate) || + IsAssumedRank(ultimate)) { + return std::nullopt; + } else if (ultimate.has()) { + return true; + } else { + return Base::operator()(ultimate); + } + } + + Result operator()(const ArrayRef &x) const { + if (x.Rank() == 0) { + return true; // scalars considered contiguous + } + int subscriptRank{0}; + auto baseLbounds{GetLBOUNDs(context_, x.base())}; + auto baseUbounds{GetUBOUNDs(context_, x.base())}; + auto subscripts{CheckSubscripts( + x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)}; + if (!subscripts.value_or(false)) { + return subscripts; // subscripts not known to be contiguous + } else if (subscriptRank > 0) { + // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous. + return (*this)(x.base()); + } else { + // a(:)%b(1,1) is (probably) not contiguous. + return std::nullopt; + } + } + Result operator()(const CoarrayRef &x) const { return (*this)(x.base()); } + Result operator()(const Component &x) const { + if (x.base().Rank() == 0) { + return (*this)(x.GetLastSymbol()); + } else { + const DataRef &base{x.base()}; + if (Result baseIsContiguous{(*this)(base)}) { + if (!*baseIsContiguous) { + return false; + } else { + bool sizeKnown{false}; + if (auto constShape{GetConstantExtents(context_, x)}) { + sizeKnown = true; + if (GetSize(*constShape) <= 1) { + return true; // empty or singleton + } + } + const Symbol &last{base.GetLastSymbol()}; + if (auto type{DynamicType::From(last)}) { + CHECK(type->category() == TypeCategory::Derived); + if (!type->IsPolymorphic()) { + const auto &derived{type->GetDerivedTypeSpec()}; + if (const auto *scope{derived.scope()}) { + auto iter{scope->begin()}; + if (++iter == scope->end()) { + return true; // type has but one component + } else if (sizeKnown) { + return false; // multiple components & array size is known > 1 + } + } + } + } + } + } + return std::nullopt; + } + } + Result operator()(const ComplexPart &x) const { + // TODO: should be true when base is empty array or singleton, too + return x.complex().Rank() == 0; + } + Result operator()(const Substring &x) const { + if (x.Rank() == 0) { + return true; // scalar substring always contiguous + } + // Substrings with rank must have DataRefs as their parents + const DataRef &parentDataRef{DEREF(x.GetParentIf())}; + std::optional len; + if (auto lenExpr{parentDataRef.LEN()}) { + len = ToInt64(Fold(context_, std::move(*lenExpr))); + if (len) { + if (*len <= 0) { + return true; // empty substrings + } else if (*len == 1) { + // Substrings can't be incomplete; is base array contiguous? + return (*this)(parentDataRef); + } + } + } + std::optional upper; + bool upperIsLen{false}; + if (auto upperExpr{x.upper()}) { + upper = ToInt64(Fold(context_, common::Clone(*upperExpr))); + if (upper) { + if (*upper < 1) { + return true; // substring(n:0) empty + } + upperIsLen = len && *upper >= *len; + } else if (const auto *inquiry{ + UnwrapConvertedExpr(*upperExpr)}; + inquiry && inquiry->field() == DescriptorInquiry::Field::Len) { + upperIsLen = + &parentDataRef.GetLastSymbol() == &inquiry->base().GetLastSymbol(); + } + } else { + upperIsLen = true; // substring(n:) + } + if (auto lower{ToInt64(Fold(context_, x.lower()))}) { + if (*lower == 1 && upperIsLen) { + // known complete substring; is base contiguous? + return (*this)(parentDataRef); + } else if (upper) { + if (*upper < *lower) { + return true; // empty substring(3:2) + } else if (*lower > 1) { + return false; // known incomplete substring + } else if (len && *upper < *len) { + return false; // known incomplete substring + } + } + } + return std::nullopt; // contiguity not known + } + + Result operator()(const ProcedureRef &x) const { + if (auto chars{characteristics::Procedure::Characterize( + x.proc(), context_, /*emitError=*/true)}) { + if (chars->functionResult) { + const auto &result{*chars->functionResult}; + if (!result.IsProcedurePointer()) { + if (result.attrs.test( + characteristics::FunctionResult::Attr::Contiguous)) { + return true; + } + if (!result.attrs.test( + characteristics::FunctionResult::Attr::Pointer)) { + return true; + } + if (const auto *type{result.GetTypeAndShape()}; + type && type->Rank() == 0) { + return true; // pointer to scalar + } + // Must be non-CONTIGUOUS pointer to array + } + } + } + return std::nullopt; + } + + Result operator()(const NullPointer &) const { return true; } + +private: + // Returns "true" for a provably empty or simply contiguous array section; + // return "false" for a provably nonempty discontiguous section or for use + // of a vector subscript. + std::optional CheckSubscripts(const std::vector &subscript, + int &rank, const Shape *baseLbounds = nullptr, + const Shape *baseUbounds = nullptr) const { + bool anyTriplet{false}; + rank = 0; + // Detect any provably empty dimension in this array section, which would + // render the whole section empty and therefore vacuously contiguous. + std::optional result; + bool mayBeEmpty{false}; + auto dims{subscript.size()}; + std::vector knownPartialSlice(dims, false); + for (auto j{dims}; j-- > 0;) { + if (j == 0 && firstDimensionStride1_ && !result.value_or(true)) { + result.reset(); // ignore problems on later dimensions + } + std::optional dimLbound; + std::optional dimUbound; + std::optional dimExtent; + if (baseLbounds && j < baseLbounds->size()) { + if (const auto &lb{baseLbounds->at(j)}) { + dimLbound = ToInt64(Fold(context_, Expr{*lb})); + } + } + if (baseUbounds && j < baseUbounds->size()) { + if (const auto &ub{baseUbounds->at(j)}) { + dimUbound = ToInt64(Fold(context_, Expr{*ub})); + } + } + if (dimLbound && dimUbound) { + if (*dimLbound <= *dimUbound) { + dimExtent = *dimUbound - *dimLbound + 1; + } else { + // This is an empty dimension. + result = true; + dimExtent = 0; + } + } + if (const auto *triplet{std::get_if(&subscript[j].u)}) { + ++rank; + const Expr *lowerBound{triplet->GetLower()}; + const Expr *upperBound{triplet->GetUpper()}; + std::optional lowerVal{lowerBound + ? ToInt64(Fold(context_, Expr{*lowerBound})) + : dimLbound}; + std::optional upperVal{upperBound + ? ToInt64(Fold(context_, Expr{*upperBound})) + : dimUbound}; + if (auto stride{ToInt64(triplet->stride())}) { + if (j == 0 && *stride == 1 && firstDimensionStride1_) { + result = *stride == 1; // contiguous or empty if so + } + if (lowerVal && upperVal) { + if (*lowerVal < *upperVal) { + if (*stride < 0) { + result = true; // empty dimension + } else if (!result && *stride > 1 && + *lowerVal + *stride <= *upperVal) { + result = false; // discontiguous if not empty + } + } else if (*lowerVal > *upperVal) { + if (*stride > 0) { + result = true; // empty dimension + } else if (!result && *stride < 0 && + *lowerVal + *stride >= *upperVal) { + result = false; // discontiguous if not empty + } + } else { // bounds known and equal + if (j == 0 && firstDimensionStride1_) { + result = true; // stride doesn't matter + } + } + } else { // bounds not both known + mayBeEmpty = true; + } + } else { // stride not known + if (lowerVal && upperVal && *lowerVal == *upperVal) { + // stride doesn't matter when bounds are equal + if (j == 0 && firstDimensionStride1_) { + result = true; + } + } else { + mayBeEmpty = true; + } + } + } else if (subscript[j].Rank() > 0) { // vector subscript + ++rank; + if (!result) { + result = false; + } + mayBeEmpty = true; + } else { // scalar subscript + if (dimExtent && *dimExtent > 1) { + knownPartialSlice[j] = true; + } + } + } + if (rank == 0) { + result = true; // scalar + } + if (result) { + return result; + } + // Not provably contiguous or discontiguous at this point. + // Return "true" if simply contiguous, otherwise nullopt. + for (auto j{subscript.size()}; j-- > 0;) { + if (const auto *triplet{std::get_if(&subscript[j].u)}) { + auto stride{ToInt64(triplet->stride())}; + if (!stride || stride != 1) { + return std::nullopt; + } else if (anyTriplet) { + if (triplet->GetLower() || triplet->GetUpper()) { + // all triplets before the last one must be just ":" for + // simple contiguity + return std::nullopt; + } + } else { + anyTriplet = true; + } + ++rank; + } else if (anyTriplet) { + // If the section cannot be empty, and this dimension's + // scalar subscript is known not to cover the whole + // dimension, then the array section is provably + // discontiguous. + return (mayBeEmpty || !knownPartialSlice[j]) + ? std::nullopt + : std::make_optional(false); + } + } + return true; // simply contiguous + } + + FoldingContext &context_; + bool namedConstantSectionsAreContiguous_{false}; + bool firstDimensionStride1_{false}; +}; + +template +std::optional IsContiguous(const A &x, FoldingContext &context, + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1) { + if (!IsVariable(x) && + (namedConstantSectionsAreContiguous || !ExtractDataRef(x, true, true))) { + return true; + } else { + return IsContiguousHelper{ + context, namedConstantSectionsAreContiguous, firstDimensionStride1}(x); + } +} + +std::optional IsContiguous(const ActualArgument &actual, + FoldingContext &fc, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1) { + auto *expr{actual.UnwrapExpr()}; + return expr && + IsContiguous( + *expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1); +} + +template std::optional IsContiguous(const Expr &, + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); +template std::optional IsContiguous(const ActualArgument &, + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); +template std::optional IsContiguous(const ArrayRef &, FoldingContext &, + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); +template std::optional IsContiguous(const Substring &, FoldingContext &, + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); +template std::optional IsContiguous(const Component &, FoldingContext &, + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); +template std::optional IsContiguous(const ComplexPart &, FoldingContext &, + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); +template std::optional IsContiguous(const CoarrayRef &, FoldingContext &, + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); +template std::optional IsContiguous(const Symbol &, FoldingContext &, + bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); + +// IsErrorExpr() +struct IsErrorExprHelper : public AnyTraverse { + using Result = bool; + using Base = AnyTraverse; + IsErrorExprHelper() : Base{*this} {} + using Base::operator(); + + bool operator()(const SpecificIntrinsic &x) { + return x.name == IntrinsicProcTable::InvalidName; + } +}; + +template bool IsErrorExpr(const A &x) { + return IsErrorExprHelper{}(x); +} + +template bool IsErrorExpr(const Expr &); + +// C1577 +// TODO: Also check C1579 & C1582 here +class StmtFunctionChecker + : public AnyTraverse> { +public: + using Result = std::optional; + using Base = AnyTraverse; + + static constexpr auto feature{ + common::LanguageFeature::StatementFunctionExtensions}; + + StmtFunctionChecker(const Symbol &sf, FoldingContext &context) + : Base{*this}, sf_{sf}, context_{context} { + if (!context_.languageFeatures().IsEnabled(feature)) { + severity_ = parser::Severity::Error; + } else if (context_.languageFeatures().ShouldWarn(feature)) { + severity_ = parser::Severity::Portability; + } + } + using Base::operator(); + + Result Return(parser::Message &&msg) const { + if (severity_) { + msg.set_severity(*severity_); + if (*severity_ != parser::Severity::Error) { + msg.set_languageFeature(feature); + } + } + return std::move(msg); + } + + template Result operator()(const ArrayConstructor &) const { + if (severity_) { + return Return(parser::Message{sf_.name(), + "Statement function '%s' should not contain an array constructor"_port_en_US, + sf_.name()}); + } else { + return std::nullopt; + } + } + Result operator()(const StructureConstructor &) const { + if (severity_) { + return Return(parser::Message{sf_.name(), + "Statement function '%s' should not contain a structure constructor"_port_en_US, + sf_.name()}); + } else { + return std::nullopt; + } + } + Result operator()(const TypeParamInquiry &) const { + if (severity_) { + return Return(parser::Message{sf_.name(), + "Statement function '%s' should not contain a type parameter inquiry"_port_en_US, + sf_.name()}); + } else { + return std::nullopt; + } + } + Result operator()(const ProcedureDesignator &proc) const { + if (const Symbol *symbol{proc.GetSymbol()}) { + const Symbol &ultimate{symbol->GetUltimate()}; + if (const auto *subp{ + ultimate.detailsIf()}) { + if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) { + if (ultimate.name().begin() > sf_.name().begin()) { + return parser::Message{sf_.name(), + "Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US, + sf_.name(), ultimate.name()}; + } + } + } + if (auto chars{characteristics::Procedure::Characterize( + proc, context_, /*emitError=*/true)}) { + if (!chars->CanBeCalledViaImplicitInterface()) { + if (severity_) { + return Return(parser::Message{sf_.name(), + "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US, + sf_.name(), symbol->name()}); + } + } + } + } + if (proc.Rank() > 0) { + if (severity_) { + return Return(parser::Message{sf_.name(), + "Statement function '%s' should not reference a function that returns an array"_port_en_US, + sf_.name()}); + } + } + return std::nullopt; + } + Result operator()(const ActualArgument &arg) const { + if (const auto *expr{arg.UnwrapExpr()}) { + if (auto result{(*this)(*expr)}) { + return result; + } + if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) { + if (severity_) { + return Return(parser::Message{sf_.name(), + "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US, + sf_.name()}); + } + } + } + return std::nullopt; + } + +private: + const Symbol &sf_; + FoldingContext &context_; + std::optional severity_; +}; + +std::optional CheckStatementFunction( + const Symbol &sf, const Expr &expr, FoldingContext &context) { + return StmtFunctionChecker{sf, context}(expr); +} + +// Helper class for checking differences between actual and dummy arguments +class CopyInOutExplicitInterface { +public: + explicit CopyInOutExplicitInterface(FoldingContext &fc, + const ActualArgument &actual, + const characteristics::DummyDataObject &dummyObj) + : fc_{fc}, actual_{actual}, dummyObj_{dummyObj} {} + + // Returns true, if actual and dummy have different contiguity requirements + bool HaveContiguityDifferences() const { + // Check actual contiguity, unless dummy doesn't care + bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)}; + bool actualTreatAsContiguous{ + dummyObj_.ignoreTKR.test(common::IgnoreTKR::Contiguous) || + IsSimplyContiguous(actual_, fc_)}; + bool dummyIsExplicitShape{dummyObj_.type.IsExplicitShape()}; + bool dummyIsAssumedSize{dummyObj_.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedSize)}; + bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()}; + // type(*) with IGNORE_TKR(tkr) is often used to interface with C "void*". + // Since the other languages don't know about Fortran's discontiguity + // handling, such cases should require contiguity. + bool dummyIsVoidStar{dummyObj_.type.type().IsAssumedType() && + dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type) && + dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank) && + dummyObj_.ignoreTKR.test(common::IgnoreTKR::Kind)}; + // Explicit shape and assumed size arrays must be contiguous + bool dummyNeedsContiguity{dummyIsExplicitShape || dummyIsAssumedSize || + (dummyTreatAsArray && !dummyIsPolymorphic) || dummyIsVoidStar || + dummyObj_.attrs.test( + characteristics::DummyDataObject::Attr::Contiguous)}; + return !actualTreatAsContiguous && dummyNeedsContiguity; + } + + // Returns true, if actual and dummy have polymorphic differences + bool HavePolymorphicDifferences() const { + bool dummyIsAssumedRank{dummyObj_.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedRank)}; + bool actualIsAssumedRank{semantics::IsAssumedRank(actual_)}; + bool dummyIsAssumedShape{dummyObj_.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedShape)}; + bool actualIsAssumedShape{semantics::IsAssumedShape(actual_)}; + if ((actualIsAssumedRank && dummyIsAssumedRank) || + (actualIsAssumedShape && dummyIsAssumedShape)) { + // Assumed-rank and assumed-shape arrays are represented by descriptors, + // so don't need to do polymorphic check. + } else if (!dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) { + // flang supports limited cases of passing polymorphic to non-polimorphic. + // These cases require temporary of non-polymorphic type. (For example, + // the actual argument could be polymorphic array of child type, + // while the dummy argument could be non-polymorphic array of parent + // type.) + bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()}; + auto actualType{ + characteristics::TypeAndShape::Characterize(actual_, fc_)}; + bool actualIsPolymorphic{ + actualType && actualType->type().IsPolymorphic()}; + if (actualIsPolymorphic && !dummyIsPolymorphic) { + return true; + } + } + return false; + } + + bool HaveArrayOrAssumedRankArgs() const { + bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)}; + return IsArrayOrAssumedRank(actual_) && + (IsArrayOrAssumedRank(dummyObj_) || dummyTreatAsArray); + } + + bool PassByValue() const { + return dummyObj_.attrs.test(characteristics::DummyDataObject::Attr::Value); + } + + bool HaveCoarrayDifferences() const { + return ExtractCoarrayRef(actual_) && dummyObj_.type.corank() == 0; + } + + bool HasIntentOut() const { return dummyObj_.intent == common::Intent::Out; } + + bool HasIntentIn() const { return dummyObj_.intent == common::Intent::In; } + + static bool IsArrayOrAssumedRank(const ActualArgument &actual) { + return semantics::IsAssumedRank(actual) || actual.Rank() > 0; + } + + static bool IsArrayOrAssumedRank( + const characteristics::DummyDataObject &dummy) { + return dummy.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedRank) || + dummy.type.Rank() > 0; + } + +private: + FoldingContext &fc_; + const ActualArgument &actual_; + const characteristics::DummyDataObject &dummyObj_; +}; + +// If forCopyOut is false, returns if a particular actual/dummy argument +// combination may need a temporary creation with copy-in operation. If +// forCopyOut is true, returns the same for copy-out operation. For +// procedures with explicit interface, it's expected that "dummy" is not null. +// For procedures with implicit interface dummy may be null. +// +// Note that these copy-in and copy-out checks are done from the caller's +// perspective, meaning that for copy-in the caller need to do the copy +// before calling the callee. Similarly, for copy-out the caller is expected +// to do the copy after the callee returns. +bool MayNeedCopy(const ActualArgument *actual, + const characteristics::DummyArgument *dummy, FoldingContext &fc, + bool forCopyOut) { + if (!actual) { + return false; + } + if (actual->isAlternateReturn()) { + return false; + } + const auto *dummyObj{dummy + ? std::get_if(&dummy->u) + : nullptr}; + const bool forCopyIn = !forCopyOut; + if (!evaluate::IsVariable(*actual)) { + // Actual argument expressions that aren’t variables are copy-in, but + // not copy-out. + return forCopyIn; + } + if (dummyObj) { // Explict interface + CopyInOutExplicitInterface check{fc, *actual, *dummyObj}; + if (forCopyOut && check.HasIntentIn()) { + // INTENT(IN) dummy args never need copy-out + return false; + } + if (forCopyIn && check.HasIntentOut()) { + // INTENT(OUT) dummy args never need copy-in + return false; + } + if (check.PassByValue()) { + // Pass by value, always copy-in, never copy-out + return forCopyIn; + } + if (check.HaveCoarrayDifferences()) { + return true; + } + // Note: contiguity and polymorphic checks deal with array or assumed rank + // arguments + if (!check.HaveArrayOrAssumedRankArgs()) { + return false; + } + if (check.HaveContiguityDifferences()) { + return true; + } + if (check.HavePolymorphicDifferences()) { + return true; + } + } else { // Implicit interface + if (ExtractCoarrayRef(*actual)) { + // Coindexed actual args may need copy-in and copy-out with implicit + // interface + return true; + } + if (!IsSimplyContiguous(*actual, fc)) { + // Copy-in: actual arguments that are variables are copy-in when + // non-contiguous. + // Copy-out: vector subscripts could refer to duplicate elements, can't + // copy out. + return !(forCopyOut && HasVectorSubscript(*actual)); + } + } + // For everything else, no copy-in or copy-out + return false; +} + +} // namespace Fortran::evaluate