[flang-commits] [flang] [Flang] Add parsing and attribute registration for SIMPLE procedures (PR #159763)
Šárka Holendová via flang-commits
flang-commits at lists.llvm.org
Fri Sep 26 09:50:35 PDT 2025
https://github.com/mlir-maiden updated https://github.com/llvm/llvm-project/pull/159763
>From c37da6820a94ce63e1f9c8f44063bb4997f4f69e Mon Sep 17 00:00:00 2001
From: Sarka Holendova <sarka.holendova at gmail.com>
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<AssumedType>(&u_)}) {
+ if (const AssumedType *aType{std::get_if<AssumedType>(&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<Expr<SubscriptInteger>> 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<Attr, Attr_enumSize>;
- 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<T> &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<Component>(&ref->u)}) {
+ if (const Component *component{std::get_if<Component>(&ref->u)}) {
ref = skipComponents ? &component->base() : nullptr;
} else if (const auto *coarrayRef{std::get_if<CoarrayRef>(&ref->u)}) {
ref = &coarrayRef->base();
@@ -436,7 +436,7 @@ struct ExtractCoindexedObjectHelper {
return common::visit(*this, dataRef.u);
}
std::optional<CoarrayRef> 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 <typename A> 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 <typename A> 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<Expr<SomeType>>(const Expr<SomeType> &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<semantics::SubprogramDetails>()}) {
if (details->isFunction() &&
@@ -992,7 +992,7 @@ inline semantics::Attrs GetAttrs<Expr<SomeType>>(const Expr<SomeType> &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<common::CUDASubprogramAttrs>);
WRAPPER_CLASS(Launch_Bounds, std::list<ScalarIntConstantExpr>);
WRAPPER_CLASS(Cluster_Dims, std::list<ScalarIntConstantExpr>);
std::variant<DeclarationTypeSpec, Elemental, Impure, Module, Non_Recursive,
- Pure, Recursive, Attributes, Launch_Bounds, Cluster_Dims>
+ 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<Attr, Attr_enumSize> {
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<DynamicType> 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<semantics::ProcEntityDetails>()}) {
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<SpecificIntrinsic>(&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<SpecificIntrinsic>(&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<SpecificIntrinsic>(&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<SpecificIntrinsic>(&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 <set>
-#include <string>
-
-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 <bool INVARIANT>
-class IsConstantExprHelper
- : public AllTraverse<IsConstantExprHelper<INVARIANT>, true> {
-public:
- using Base = AllTraverse<IsConstantExprHelper, true>;
- IsConstantExprHelper() : Base{*this} {}
- using Base::operator();
-
- // A missing expression is not considered to be constant.
- template <typename A> bool operator()(const std::optional<A> &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<semantics::TypeParamDetails>() ||
- (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 <int KIND>
- bool operator()(
- const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
- using T = Type<TypeCategory::Integer, KIND>;
- if ((*this)(division.left()) && (*this)(division.right())) {
- const auto divisor{GetScalarConstantValue<T>(division.right())};
- return !divisor || !divisor->IsZero();
- } else {
- return false;
- }
- }
-
- bool operator()(const Constant<SomeDerived> &) 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<SomeType> &) const;
- bool IsConstantExprShape(const Shape &) const;
-};
-
-template <bool INVARIANT>
-bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
- const Symbol &component, const Expr<SomeType> &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 INVARIANT>
-bool IsConstantExprHelper<INVARIANT>::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<SpecificIntrinsic>(&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<characteristics::DummyDataObject>(
- &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 INVARIANT>
-bool IsConstantExprHelper<INVARIANT>::IsConstantExprShape(
- const Shape &shape) const {
- for (const auto &extent : shape) {
- if (!(*this)(extent)) {
- return false;
- }
- }
- return true;
-}
-
-template <typename A> bool IsConstantExpr(const A &x) {
- return IsConstantExprHelper<false>{}(x);
-}
-template bool IsConstantExpr(const Expr<SomeType> &);
-template bool IsConstantExpr(const Expr<SomeInteger> &);
-template bool IsConstantExpr(const Expr<SubscriptInteger> &);
-template bool IsConstantExpr(const StructureConstructor &);
-
-// IsScopeInvariantExpr()
-template <typename A> bool IsScopeInvariantExpr(const A &x) {
- return IsConstantExprHelper<true>{}(x);
-}
-template bool IsScopeInvariantExpr(const Expr<SomeType> &);
-template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
-template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
-
-// IsActuallyConstant()
-struct IsActuallyConstantHelper {
- template <typename A> bool operator()(const A &) { return false; }
- template <typename T> bool operator()(const Constant<T> &) { return true; }
- template <typename T> bool operator()(const Parentheses<T> &x) {
- return (*this)(x.left());
- }
- template <typename T> bool operator()(const Expr<T> &x) {
- return common::visit([=](const auto &y) { return (*this)(y); }, x.u);
- }
- bool operator()(const Expr<SomeType> &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<SomeType> &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 <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
- template <typename A> bool operator()(const std::optional<A> &x) {
- return x && (*this)(*x);
- }
-};
-
-template <typename A> bool IsActuallyConstant(const A &x) {
- return IsActuallyConstantHelper{}(x);
-}
-
-template bool IsActuallyConstant(const Expr<SomeType> &);
-template bool IsActuallyConstant(const Expr<SomeInteger> &);
-template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
-template bool IsActuallyConstant(const std::optional<Expr<SubscriptInteger>> &);
-
-// 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<IsInitialDataTargetHelper, true> {
-public:
- using Base = AllTraverse<IsInitialDataTargetHelper, true>;
- 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 <typename T> bool operator()(const Constant<T> &) 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<semantics::AssocEntityDetails>()}) {
- 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 <typename T> bool operator()(const ArrayConstructor<T> &) const {
- return false;
- }
- bool operator()(const StructureConstructor &) const { return false; }
- template <typename D, typename R, typename... O>
- bool operator()(const Operation<D, R, O...> &) const {
- return false;
- }
- template <typename T> bool operator()(const Parentheses<T> &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<SomeType> &) 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<SomeType> &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<SomeType> &expr) {
- if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
- return IsInitialProcedureTarget(*proc);
- } else {
- return IsNullProcedurePointer(&expr);
- }
-}
-
-class SuspiciousRealLiteralFinder
- : public AnyTraverse<SuspiciousRealLiteralFinder> {
-public:
- using Base = AnyTraverse<SuspiciousRealLiteralFinder>;
- SuspiciousRealLiteralFinder(int kind, FoldingContext &c)
- : Base{*this}, kind_{kind}, context_{c} {}
- using Base::operator();
- template <int KIND>
- bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &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 <int KIND>
- bool operator()(const Constant<Type<TypeCategory::Complex, KIND>> &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 <TypeCategory TOCAT, int TOKIND, TypeCategory FROMCAT>
- bool operator()(const Convert<Type<TOCAT, TOKIND>, 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<SomeType> &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<SomeType> &expr,
- const std::optional<DynamicType> &toType, FoldingContext &context) {
- if (toType) {
- CheckRealWidening(expr, *toType, context);
- }
-}
-
-class InexactLiteralConversionFlagClearer
- : public AnyTraverse<InexactLiteralConversionFlagClearer> {
-public:
- using Base = AnyTraverse<InexactLiteralConversionFlagClearer>;
- InexactLiteralConversionFlagClearer() : Base(*this) {}
- using Base::operator();
- template <int KIND>
- bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &x) const {
- auto &mut{const_cast<Type<TypeCategory::Real, KIND> &>(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<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
- Expr<SomeType> &&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<SomeType>{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<CheckSpecificationExprHelper,
- std::optional<std::string>> {
-public:
- using Result = std::optional<std::string>;
- using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
- 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<semantics::ObjectEntityDetails>()};
- 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<semantics::AssocEntityDetails>()}) {
- 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<semantics::ObjectEntityDetails>()) {
- 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<semantics::ObjectEntityDetails>()}) {
- 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<characteristics::DummyProcedure>(
- 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<characteristics::DummyDataObject>(
- &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<std::string> 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<semantics::UseDetails>() ||
- symbol.owner().kind() == semantics::Scope::Kind::Module ||
- semantics::FindCommonBlockContaining(symbol) ||
- symbol.has<semantics::HostAssocDetails>()) {
- 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<semantics::ObjectEntityDetails>()};
- 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 <typename A>
-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<SomeType> &,
- const semantics::Scope &, FoldingContext &,
- bool forElementalFunctionResult);
-template void CheckSpecificationExpr(const Expr<SomeInteger> &,
- const semantics::Scope &, FoldingContext &,
- bool forElementalFunctionResult);
-template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
- const semantics::Scope &, FoldingContext &,
- bool forElementalFunctionResult);
-template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
- const semantics::Scope &, FoldingContext &,
- bool forElementalFunctionResult);
-template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
- const semantics::Scope &, FoldingContext &,
- bool forElementalFunctionResult);
-template void CheckSpecificationExpr(
- const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
- FoldingContext &, bool forElementalFunctionResult);
-
-// IsContiguous() -- 9.5.4
-class IsContiguousHelper
- : public AnyTraverse<IsContiguousHelper, std::optional<bool>> {
-public:
- using Result = std::optional<bool>; // tri-state
- using Base = AnyTraverse<IsContiguousHelper, Result>;
- explicit IsContiguousHelper(FoldingContext &c,
- bool namedConstantSectionsAreContiguous,
- bool firstDimensionStride1 = false)
- : Base{*this}, context_{c},
- namedConstantSectionsAreContiguous_{namedConstantSectionsAreContiguous},
- firstDimensionStride1_{firstDimensionStride1} {}
- using Base::operator();
-
- template <typename T> Result operator()(const Constant<T> &) 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<semantics::AssocEntityDetails>()}) {
- // 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<semantics::ObjectEntityDetails>()) {
- 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<DataRef>())};
- std::optional<std::int64_t> 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<std::int64_t> 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<DescriptorInquiry>(*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<bool> CheckSubscripts(const std::vector<Subscript> &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<bool> result;
- bool mayBeEmpty{false};
- auto dims{subscript.size()};
- std::vector<bool> 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<ConstantSubscript> dimLbound;
- std::optional<ConstantSubscript> dimUbound;
- std::optional<ConstantSubscript> dimExtent;
- if (baseLbounds && j < baseLbounds->size()) {
- if (const auto &lb{baseLbounds->at(j)}) {
- dimLbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*lb}));
- }
- }
- if (baseUbounds && j < baseUbounds->size()) {
- if (const auto &ub{baseUbounds->at(j)}) {
- dimUbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*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<Triplet>(&subscript[j].u)}) {
- ++rank;
- const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()};
- const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()};
- std::optional<ConstantSubscript> lowerVal{lowerBound
- ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound}))
- : dimLbound};
- std::optional<ConstantSubscript> upperVal{upperBound
- ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*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<Triplet>(&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 <typename A>
-std::optional<bool> 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<bool> IsContiguous(const ActualArgument &actual,
- FoldingContext &fc, bool namedConstantSectionsAreContiguous,
- bool firstDimensionStride1) {
- auto *expr{actual.UnwrapExpr()};
- return expr &&
- IsContiguous(
- *expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1);
-}
-
-template std::optional<bool> IsContiguous(const Expr<SomeType> &,
- FoldingContext &, bool namedConstantSectionsAreContiguous,
- bool firstDimensionStride1);
-template std::optional<bool> IsContiguous(const ActualArgument &,
- FoldingContext &, bool namedConstantSectionsAreContiguous,
- bool firstDimensionStride1);
-template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &,
- bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
-template std::optional<bool> IsContiguous(const Substring &, FoldingContext &,
- bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
-template std::optional<bool> IsContiguous(const Component &, FoldingContext &,
- bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
-template std::optional<bool> IsContiguous(const ComplexPart &, FoldingContext &,
- bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
-template std::optional<bool> IsContiguous(const CoarrayRef &, FoldingContext &,
- bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
-template std::optional<bool> IsContiguous(const Symbol &, FoldingContext &,
- bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
-
-// IsErrorExpr()
-struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
- using Result = bool;
- using Base = AnyTraverse<IsErrorExprHelper, Result>;
- IsErrorExprHelper() : Base{*this} {}
- using Base::operator();
-
- bool operator()(const SpecificIntrinsic &x) {
- return x.name == IntrinsicProcTable::InvalidName;
- }
-};
-
-template <typename A> bool IsErrorExpr(const A &x) {
- return IsErrorExprHelper{}(x);
-}
-
-template bool IsErrorExpr(const Expr<SomeType> &);
-
-// C1577
-// TODO: Also check C1579 & C1582 here
-class StmtFunctionChecker
- : public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> {
-public:
- using Result = std::optional<parser::Message>;
- using Base = AnyTraverse<StmtFunctionChecker, Result>;
-
- 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 <typename T> Result operator()(const ArrayConstructor<T> &) 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<semantics::SubprogramDetails>()}) {
- 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<parser::Severity> severity_;
-};
-
-std::optional<parser::Message> CheckStatementFunction(
- const Symbol &sf, const Expr<SomeType> &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<characteristics::DummyDataObject>(&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<SomeType> &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<SomeType> &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<parser::MessageFixedText> 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> &dataRef) {
}
const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &dataRef) {
- if (const Component * c{std::get_if<Component>(&dataRef.u)}) {
+ if (const Component *c{std::get_if<Component>(&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<CoarrayRef>(&dataRef.u)}) {
+ if (const CoarrayRef *c{std::get_if<CoarrayRef>(&dataRef.u)}) {
return UnwrapWholeSymbolOrComponentOrCoarrayRef(c->base());
} else {
return UnwrapWholeSymbolOrComponentDataRef(dataRef);
@@ -1415,7 +1421,7 @@ static std::optional<Expr<SomeType>> 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<SomeType> &expr) {
bool IsAllocatableDesignator(const Expr<SomeType> &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<AssocEntityDetails>()}) {
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<AssocEntityDetails>()}) {
- 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<SubprogramDetails>()}) {
- 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<ObjectEntityDetails>()}) {
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<ObjectEntityDetails>()}) {
result = object->ignoreTKR();
- if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {
+ if (const Symbol *ownerSymbol{symbol.owner().symbol()}) {
if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()}) {
if (ownerSubp->defaultIgnoreTKR()) {
result |= common::ignoreTKRAll;
@@ -2527,7 +2542,7 @@ common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {
std::optional<int> 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<SubprogramDetails>()}) {
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<semantics::ModuleDetails>()};
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<AltReturnSpec>(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<PrefixSpec>(declarationTypeSpec),
construct<PrefixSpec::Non_Recursive>("NON_RECURSIVE"_tok)),
construct<PrefixSpec>(construct<PrefixSpec::Pure>("PURE"_tok)),
construct<PrefixSpec>(construct<PrefixSpec::Recursive>("RECURSIVE"_tok)),
+ construct<PrefixSpec>(construct<PrefixSpec::Simple>("SIMPLE"_tok)),
extension<LanguageFeature::CUDA>(
construct<PrefixSpec>(construct<PrefixSpec::Attributes>("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<DerivedTypeSpec *>(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<SubprogramDetails>()};
- subp && !subp->isInterface()) {
+ subp && !subp->isInterface()) {
return false; // defined in module, not an external
} else if (const auto *subp{p2.detailsIf<SubprogramDetails>()};
- 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<SourceName> 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<parser::Name> &names, ProcedureKind kind) {
- if (Symbol * symbol{GetGenericInfo().symbol};
+ if (Symbol *symbol{GetGenericInfo().symbol};
symbol && symbol->has<GenericDetails>()) {
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<GenericDetails>()) {
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<EntityDetails>()};
- entity && !ultimate.has<ProcEntityDetails>()) {
+ entity && !ultimate.has<ProcEntityDetails>()) {
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<Symbol *>(defnIface);
}
@@ -5189,8 +5190,8 @@ bool SubprogramVisitor::HandlePreviousCalls(
return generic->specific() &&
HandlePreviousCalls(name, *generic->specific(), subpFlag);
} else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}; 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<EntityDetails>()};
- 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<HostAssocDetails>()) {
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<parser::Name>(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<parser::DataStmtConstant &>(data)};
if (auto *elem{parser::Unwrap<parser::ArrayElement>(mutableData)}) {
if (const auto *name{std::get_if<parser::Name>(&elem->base.u)}) {
- if (const Symbol * symbol{FindSymbol(*name)};
+ if (const Symbol *symbol{FindSymbol(*name)};
symbol && symbol->GetUltimate().has<DerivedTypeDetails>()) {
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<Symbol &>(*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<parser::ObjectName>(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<ProcEntityDetails>()}; 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<parser::Name>(expr)}) {
+ if (const parser::Name *name{parser::Unwrap<parser::Name>(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<ObjectEntityDetails>()}) {
- 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<ObjectEntityDetails>()}) {
auto origDetails{origComp.get<ObjectEntityDetails>()};
- 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 <sarka.holendova at gmail.com>
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 <set>
+#include <string>
+
+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 <bool INVARIANT>
+class IsConstantExprHelper
+ : public AllTraverse<IsConstantExprHelper<INVARIANT>, true> {
+public:
+ using Base = AllTraverse<IsConstantExprHelper, true>;
+ IsConstantExprHelper() : Base{*this} {}
+ using Base::operator();
+
+ // A missing expression is not considered to be constant.
+ template <typename A> bool operator()(const std::optional<A> &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<semantics::TypeParamDetails>() ||
+ (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 <int KIND>
+ bool operator()(
+ const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
+ using T = Type<TypeCategory::Integer, KIND>;
+ if ((*this)(division.left()) && (*this)(division.right())) {
+ const auto divisor{GetScalarConstantValue<T>(division.right())};
+ return !divisor || !divisor->IsZero();
+ } else {
+ return false;
+ }
+ }
+
+ bool operator()(const Constant<SomeDerived> &) 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<SomeType> &) const;
+ bool IsConstantExprShape(const Shape &) const;
+};
+
+template <bool INVARIANT>
+bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
+ const Symbol &component, const Expr<SomeType> &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 INVARIANT>
+bool IsConstantExprHelper<INVARIANT>::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<SpecificIntrinsic>(&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<characteristics::DummyDataObject>(
+ &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 INVARIANT>
+bool IsConstantExprHelper<INVARIANT>::IsConstantExprShape(
+ const Shape &shape) const {
+ for (const auto &extent : shape) {
+ if (!(*this)(extent)) {
+ return false;
+ }
+ }
+ return true;
+}
+
+template <typename A> bool IsConstantExpr(const A &x) {
+ return IsConstantExprHelper<false>{}(x);
+}
+template bool IsConstantExpr(const Expr<SomeType> &);
+template bool IsConstantExpr(const Expr<SomeInteger> &);
+template bool IsConstantExpr(const Expr<SubscriptInteger> &);
+template bool IsConstantExpr(const StructureConstructor &);
+
+// IsScopeInvariantExpr()
+template <typename A> bool IsScopeInvariantExpr(const A &x) {
+ return IsConstantExprHelper<true>{}(x);
+}
+template bool IsScopeInvariantExpr(const Expr<SomeType> &);
+template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
+template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
+
+// IsActuallyConstant()
+struct IsActuallyConstantHelper {
+ template <typename A> bool operator()(const A &) { return false; }
+ template <typename T> bool operator()(const Constant<T> &) { return true; }
+ template <typename T> bool operator()(const Parentheses<T> &x) {
+ return (*this)(x.left());
+ }
+ template <typename T> bool operator()(const Expr<T> &x) {
+ return common::visit([=](const auto &y) { return (*this)(y); }, x.u);
+ }
+ bool operator()(const Expr<SomeType> &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<SomeType> &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 <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
+ template <typename A> bool operator()(const std::optional<A> &x) {
+ return x && (*this)(*x);
+ }
+};
+
+template <typename A> bool IsActuallyConstant(const A &x) {
+ return IsActuallyConstantHelper{}(x);
+}
+
+template bool IsActuallyConstant(const Expr<SomeType> &);
+template bool IsActuallyConstant(const Expr<SomeInteger> &);
+template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
+template bool IsActuallyConstant(const std::optional<Expr<SubscriptInteger>> &);
+
+// 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<IsInitialDataTargetHelper, true> {
+public:
+ using Base = AllTraverse<IsInitialDataTargetHelper, true>;
+ 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 <typename T> bool operator()(const Constant<T> &) 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<semantics::AssocEntityDetails>()}) {
+ 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 <typename T> bool operator()(const ArrayConstructor<T> &) const {
+ return false;
+ }
+ bool operator()(const StructureConstructor &) const { return false; }
+ template <typename D, typename R, typename... O>
+ bool operator()(const Operation<D, R, O...> &) const {
+ return false;
+ }
+ template <typename T> bool operator()(const Parentheses<T> &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<SomeType> &) 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<SomeType> &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<SomeType> &expr) {
+ if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
+ return IsInitialProcedureTarget(*proc);
+ } else {
+ return IsNullProcedurePointer(&expr);
+ }
+}
+
+class SuspiciousRealLiteralFinder
+ : public AnyTraverse<SuspiciousRealLiteralFinder> {
+public:
+ using Base = AnyTraverse<SuspiciousRealLiteralFinder>;
+ SuspiciousRealLiteralFinder(int kind, FoldingContext &c)
+ : Base{*this}, kind_{kind}, context_{c} {}
+ using Base::operator();
+ template <int KIND>
+ bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &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 <int KIND>
+ bool operator()(const Constant<Type<TypeCategory::Complex, KIND>> &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 <TypeCategory TOCAT, int TOKIND, TypeCategory FROMCAT>
+ bool operator()(const Convert<Type<TOCAT, TOKIND>, 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<SomeType> &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<SomeType> &expr,
+ const std::optional<DynamicType> &toType, FoldingContext &context) {
+ if (toType) {
+ CheckRealWidening(expr, *toType, context);
+ }
+}
+
+class InexactLiteralConversionFlagClearer
+ : public AnyTraverse<InexactLiteralConversionFlagClearer> {
+public:
+ using Base = AnyTraverse<InexactLiteralConversionFlagClearer>;
+ InexactLiteralConversionFlagClearer() : Base(*this) {}
+ using Base::operator();
+ template <int KIND>
+ bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &x) const {
+ auto &mut{const_cast<Type<TypeCategory::Real, KIND> &>(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<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
+ Expr<SomeType> &&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<SomeType>{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<CheckSpecificationExprHelper,
+ std::optional<std::string>> {
+public:
+ using Result = std::optional<std::string>;
+ using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
+ 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<semantics::ObjectEntityDetails>()};
+ 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<semantics::AssocEntityDetails>()}) {
+ 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<semantics::ObjectEntityDetails>()) {
+ 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<semantics::ObjectEntityDetails>()}) {
+ 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<characteristics::DummyProcedure>(
+ 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<characteristics::DummyDataObject>(
+ &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<std::string> 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<semantics::UseDetails>() ||
+ symbol.owner().kind() == semantics::Scope::Kind::Module ||
+ semantics::FindCommonBlockContaining(symbol) ||
+ symbol.has<semantics::HostAssocDetails>()) {
+ 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<semantics::ObjectEntityDetails>()};
+ 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 <typename A>
+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<SomeType> &,
+ const semantics::Scope &, FoldingContext &,
+ bool forElementalFunctionResult);
+template void CheckSpecificationExpr(const Expr<SomeInteger> &,
+ const semantics::Scope &, FoldingContext &,
+ bool forElementalFunctionResult);
+template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
+ const semantics::Scope &, FoldingContext &,
+ bool forElementalFunctionResult);
+template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
+ const semantics::Scope &, FoldingContext &,
+ bool forElementalFunctionResult);
+template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
+ const semantics::Scope &, FoldingContext &,
+ bool forElementalFunctionResult);
+template void CheckSpecificationExpr(
+ const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
+ FoldingContext &, bool forElementalFunctionResult);
+
+// IsContiguous() -- 9.5.4
+class IsContiguousHelper
+ : public AnyTraverse<IsContiguousHelper, std::optional<bool>> {
+public:
+ using Result = std::optional<bool>; // tri-state
+ using Base = AnyTraverse<IsContiguousHelper, Result>;
+ explicit IsContiguousHelper(FoldingContext &c,
+ bool namedConstantSectionsAreContiguous,
+ bool firstDimensionStride1 = false)
+ : Base{*this}, context_{c},
+ namedConstantSectionsAreContiguous_{namedConstantSectionsAreContiguous},
+ firstDimensionStride1_{firstDimensionStride1} {}
+ using Base::operator();
+
+ template <typename T> Result operator()(const Constant<T> &) 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<semantics::AssocEntityDetails>()}) {
+ // 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<semantics::ObjectEntityDetails>()) {
+ 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<DataRef>())};
+ std::optional<std::int64_t> 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<std::int64_t> 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<DescriptorInquiry>(*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<bool> CheckSubscripts(const std::vector<Subscript> &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<bool> result;
+ bool mayBeEmpty{false};
+ auto dims{subscript.size()};
+ std::vector<bool> 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<ConstantSubscript> dimLbound;
+ std::optional<ConstantSubscript> dimUbound;
+ std::optional<ConstantSubscript> dimExtent;
+ if (baseLbounds && j < baseLbounds->size()) {
+ if (const auto &lb{baseLbounds->at(j)}) {
+ dimLbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*lb}));
+ }
+ }
+ if (baseUbounds && j < baseUbounds->size()) {
+ if (const auto &ub{baseUbounds->at(j)}) {
+ dimUbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*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<Triplet>(&subscript[j].u)}) {
+ ++rank;
+ const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()};
+ const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()};
+ std::optional<ConstantSubscript> lowerVal{lowerBound
+ ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound}))
+ : dimLbound};
+ std::optional<ConstantSubscript> upperVal{upperBound
+ ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*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<Triplet>(&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 <typename A>
+std::optional<bool> 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<bool> IsContiguous(const ActualArgument &actual,
+ FoldingContext &fc, bool namedConstantSectionsAreContiguous,
+ bool firstDimensionStride1) {
+ auto *expr{actual.UnwrapExpr()};
+ return expr &&
+ IsContiguous(
+ *expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1);
+}
+
+template std::optional<bool> IsContiguous(const Expr<SomeType> &,
+ FoldingContext &, bool namedConstantSectionsAreContiguous,
+ bool firstDimensionStride1);
+template std::optional<bool> IsContiguous(const ActualArgument &,
+ FoldingContext &, bool namedConstantSectionsAreContiguous,
+ bool firstDimensionStride1);
+template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &,
+ bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
+template std::optional<bool> IsContiguous(const Substring &, FoldingContext &,
+ bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
+template std::optional<bool> IsContiguous(const Component &, FoldingContext &,
+ bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
+template std::optional<bool> IsContiguous(const ComplexPart &, FoldingContext &,
+ bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
+template std::optional<bool> IsContiguous(const CoarrayRef &, FoldingContext &,
+ bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
+template std::optional<bool> IsContiguous(const Symbol &, FoldingContext &,
+ bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
+
+// IsErrorExpr()
+struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
+ using Result = bool;
+ using Base = AnyTraverse<IsErrorExprHelper, Result>;
+ IsErrorExprHelper() : Base{*this} {}
+ using Base::operator();
+
+ bool operator()(const SpecificIntrinsic &x) {
+ return x.name == IntrinsicProcTable::InvalidName;
+ }
+};
+
+template <typename A> bool IsErrorExpr(const A &x) {
+ return IsErrorExprHelper{}(x);
+}
+
+template bool IsErrorExpr(const Expr<SomeType> &);
+
+// C1577
+// TODO: Also check C1579 & C1582 here
+class StmtFunctionChecker
+ : public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> {
+public:
+ using Result = std::optional<parser::Message>;
+ using Base = AnyTraverse<StmtFunctionChecker, Result>;
+
+ 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 <typename T> Result operator()(const ArrayConstructor<T> &) 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<semantics::SubprogramDetails>()}) {
+ 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<parser::Severity> severity_;
+};
+
+std::optional<parser::Message> CheckStatementFunction(
+ const Symbol &sf, const Expr<SomeType> &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<characteristics::DummyDataObject>(&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
More information about the flang-commits
mailing list