Index: flang/include/flang/Evaluate/characteristics.h =================================================================== --- flang/include/flang/Evaluate/characteristics.h +++ flang/include/flang/Evaluate/characteristics.h @@ -81,23 +81,24 @@ bool operator!=(const TypeAndShape &that) const { return !(*this == that); } static std::optional Characterize( - const semantics::Symbol &, FoldingContext &); + const semantics::Symbol &, FoldingContext &, bool invariantOnly = false); static std::optional Characterize( - const semantics::DeclTypeSpec &, FoldingContext &); + const semantics::DeclTypeSpec &, FoldingContext &, + bool invariantOnly = false); static std::optional Characterize( - const ActualArgument &, FoldingContext &); + const ActualArgument &, FoldingContext &, bool invariantOnly = false); // General case for Expr, ActualArgument, &c. template static std::optional Characterize( - const A &x, FoldingContext &context) { + const A &x, FoldingContext &context, bool invariantOnly = false) { if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) { - if (auto result{Characterize(*symbol, context)}) { + if (auto result{Characterize(*symbol, context, invariantOnly)}) { return result; } } if (auto type{x.GetType()}) { - TypeAndShape result{*type, GetShape(context, x)}; + TypeAndShape result{*type, GetShape(context, x, invariantOnly)}; if (type->category() == TypeCategory::Character) { if (const auto *chExpr{UnwrapExpr>(x)}) { if (auto length{chExpr->LEN()}) { @@ -114,14 +115,14 @@ template static std::optional Characterize( const Designator> &x, - FoldingContext &context) { + FoldingContext &context, bool invariantOnly = true) { if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) { - if (auto result{Characterize(*symbol, context)}) { + if (auto result{Characterize(*symbol, context, invariantOnly)}) { return result; } } if (auto type{x.GetType()}) { - TypeAndShape result{*type, GetShape(context, x)}; + TypeAndShape result{*type, GetShape(context, x, invariantOnly)}; if (auto length{x.LEN()}) { result.set_LEN(std::move(*length)); } @@ -131,19 +132,19 @@ } template - static std::optional Characterize( - const std::optional &x, FoldingContext &context) { + static std::optional Characterize(const std::optional &x, + FoldingContext &context, bool invariantOnly = false) { if (x) { - return Characterize(*x, context); + return Characterize(*x, context, invariantOnly); } else { return std::nullopt; } } template static std::optional Characterize( - A *ptr, FoldingContext &context) { + A *ptr, FoldingContext &context, bool invariantOnly = false) { if (ptr) { - return Characterize(std::as_const(*ptr), context); + return Characterize(std::as_const(*ptr), context, invariantOnly); } else { return std::nullopt; } @@ -181,7 +182,8 @@ private: static std::optional Characterize( - const semantics::AssocEntityDetails &, FoldingContext &); + const semantics::AssocEntityDetails &, FoldingContext &, + bool invariantOnly = true); static std::optional Characterize( const semantics::ProcEntityDetails &, FoldingContext &); void AcquireAttrs(const semantics::Symbol &); Index: flang/include/flang/Evaluate/shape.h =================================================================== --- flang/include/flang/Evaluate/shape.h +++ flang/include/flang/Evaluate/shape.h @@ -54,9 +54,14 @@ Shape Fold(FoldingContext &, Shape &&); std::optional Fold(FoldingContext &, std::optional &&); +// Computes shapes in terms of expressions that are scope-invariant, by +// default, which is nearly always what one wants outside of procedure +// characterization. template -std::optional GetShape(FoldingContext &, const A &); -template std::optional GetShape(const A &); +std::optional GetShape( + FoldingContext &, const A &, bool invariantOnly = true); +template +std::optional GetShape(const A &, bool invariantOnly = true); // The dimension argument to these inquiries is zero-based, // unlike the DIM= arguments to many intrinsics. @@ -68,31 +73,42 @@ // in those circumstances. // Similarly, GetUBOUND result will be forced to 0 on an empty dimension, // but will fail if the extent is not a compile time constant. -ExtentExpr GetRawLowerBound(const NamedEntity &, int dimension); ExtentExpr GetRawLowerBound( - FoldingContext &, const NamedEntity &, int dimension); -MaybeExtentExpr GetLBOUND(const NamedEntity &, int dimension); -MaybeExtentExpr GetLBOUND(FoldingContext &, const NamedEntity &, int dimension); -MaybeExtentExpr GetRawUpperBound(const NamedEntity &, int dimension); + const NamedEntity &, int dimension, bool invariantOnly = true); +ExtentExpr GetRawLowerBound(FoldingContext &, const NamedEntity &, + int dimension, bool invariantOnly = true); +MaybeExtentExpr GetLBOUND( + const NamedEntity &, int dimension, bool invariantOnly = true); +MaybeExtentExpr GetLBOUND(FoldingContext &, const NamedEntity &, int dimension, + bool invariantOnly = true); MaybeExtentExpr GetRawUpperBound( - FoldingContext &, const NamedEntity &, int dimension); -MaybeExtentExpr GetUBOUND(const NamedEntity &, int dimension); -MaybeExtentExpr GetUBOUND(FoldingContext &, const NamedEntity &, int dimension); + const NamedEntity &, int dimension, bool invariantOnly = true); +MaybeExtentExpr GetRawUpperBound(FoldingContext &, const NamedEntity &, + int dimension, bool invariantOnly = true); +MaybeExtentExpr GetUBOUND( + const NamedEntity &, int dimension, bool invariantOnly = true); +MaybeExtentExpr GetUBOUND(FoldingContext &, const NamedEntity &, int dimension, + bool invariantOnly = true); MaybeExtentExpr ComputeUpperBound(ExtentExpr &&lower, MaybeExtentExpr &&extent); MaybeExtentExpr ComputeUpperBound( FoldingContext &, ExtentExpr &&lower, MaybeExtentExpr &&extent); -Shape GetRawLowerBounds(const NamedEntity &); -Shape GetRawLowerBounds(FoldingContext &, const NamedEntity &); -Shape GetLBOUNDs(const NamedEntity &); -Shape GetLBOUNDs(FoldingContext &, const NamedEntity &); -Shape GetUBOUNDs(const NamedEntity &); -Shape GetUBOUNDs(FoldingContext &, const NamedEntity &); -MaybeExtentExpr GetExtent(const NamedEntity &, int dimension); -MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension); -MaybeExtentExpr GetExtent( - const Subscript &, const NamedEntity &, int dimension); +Shape GetRawLowerBounds(const NamedEntity &, bool invariantOnly = true); +Shape GetRawLowerBounds( + FoldingContext &, const NamedEntity &, bool invariantOnly = true); +Shape GetLBOUNDs(const NamedEntity &, bool invariantOnly = true); +Shape GetLBOUNDs( + FoldingContext &, const NamedEntity &, bool invariantOnly = true); +Shape GetUBOUNDs(const NamedEntity &, bool invariantOnly = true); +Shape GetUBOUNDs( + FoldingContext &, const NamedEntity &, bool invariantOnly = true); MaybeExtentExpr GetExtent( - FoldingContext &, const Subscript &, const NamedEntity &, int dimension); + const NamedEntity &, int dimension, bool invariantOnly = true); +MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension, + bool invariantOnly = true); +MaybeExtentExpr GetExtent(const Subscript &, const NamedEntity &, int dimension, + bool invariantOnly = true); +MaybeExtentExpr GetExtent(FoldingContext &, const Subscript &, + const NamedEntity &, int dimension, bool invariantOnly = true); // Compute an element count for a triplet or trip count for a DO. ExtentExpr CountTrips( @@ -115,11 +131,14 @@ using Result = std::optional; using Base = AnyTraverse; using Base::operator(); - GetShapeHelper() : Base{*this} {} - explicit GetShapeHelper(FoldingContext &c) : Base{*this}, context_{&c} {} - explicit GetShapeHelper(FoldingContext &c, bool useResultSymbolShape) - : Base{*this}, context_{&c}, useResultSymbolShape_{useResultSymbolShape} { - } + explicit GetShapeHelper(bool invariantOnly) + : Base{*this}, invariantOnly_{invariantOnly} {} + explicit GetShapeHelper(FoldingContext &c, bool invariantOnly) + : Base{*this}, context_{&c}, invariantOnly_{invariantOnly} {} + explicit GetShapeHelper( + FoldingContext &c, bool useResultSymbolShape, bool invariantOnly) + : Base{*this}, context_{&c}, useResultSymbolShape_{useResultSymbolShape}, + invariantOnly_{invariantOnly} {} Result operator()(const ImpliedDoIndex &) const { return ScalarShape(); } Result operator()(const DescriptorInquiry &) const { return ScalarShape(); } @@ -160,7 +179,7 @@ static Result ScalarShape() { return Shape{}; } static Shape ConstantShape(const Constant &); Result AsShapeResult(ExtentExpr &&) const; - static Shape CreateShape(int rank, NamedEntity &); + Shape CreateShape(int rank, NamedEntity &) const; template MaybeExtentExpr GetArrayConstructorValueExtent( @@ -215,34 +234,40 @@ FoldingContext *context_{nullptr}; bool useResultSymbolShape_{true}; + // When invariantOnly=false, the returned shape need not be invariant + // in its scope; in particular, it may contain references to dummy arguments. + bool invariantOnly_{true}; }; template -std::optional GetShape(FoldingContext &context, const A &x) { - if (auto shape{GetShapeHelper{context}(x)}) { +std::optional GetShape( + FoldingContext &context, const A &x, bool invariantOnly) { + if (auto shape{GetShapeHelper{context, invariantOnly}(x)}) { return Fold(context, std::move(shape)); } else { return std::nullopt; } } -template std::optional GetShape(const A &x) { - return GetShapeHelper{}(x); +template +std::optional GetShape(const A &x, bool invariantOnly) { + return GetShapeHelper{invariantOnly}(x); } template -std::optional GetShape(FoldingContext *context, const A &x) { +std::optional GetShape( + FoldingContext *context, const A &x, bool invariantOnly = true) { if (context) { - return GetShape(*context, x); + return GetShape(*context, x, invariantOnly); } else { - return GetShapeHelper{}(x); + return GetShapeHelper{invariantOnly}(x); } } template std::optional> GetConstantShape( FoldingContext &context, const A &x) { - if (auto shape{GetShape(context, x)}) { + if (auto shape{GetShape(context, x, /*invariantonly=*/true)}) { return AsConstantShape(context, *shape); } else { return std::nullopt; @@ -252,7 +277,7 @@ template std::optional GetConstantExtents( FoldingContext &context, const A &x) { - if (auto shape{GetShape(context, x)}) { + if (auto shape{GetShape(context, x, /*invariantOnly=*/true)}) { return AsConstantExtents(context, *shape); } else { return std::nullopt; @@ -265,7 +290,8 @@ // arguments). template std::optional GetContextFreeShape(FoldingContext &context, const A &x) { - return GetShapeHelper{context, false}(x); + return GetShapeHelper{ + context, /*useResultSymbolShape=*/false, /*invariantOnly=*/true}(x); } // Compilation-time shape conformance checking, when corresponding extents Index: flang/include/flang/Evaluate/tools.h =================================================================== --- flang/include/flang/Evaluate/tools.h +++ flang/include/flang/Evaluate/tools.h @@ -1184,6 +1184,7 @@ bool IsVariableName(const Symbol &); bool IsPureProcedure(const Symbol &); bool IsPureProcedure(const Scope &); +bool IsExplicitlyImpureProcedure(const Symbol &); bool IsElementalProcedure(const Symbol &); bool IsFunction(const Symbol &); bool IsFunction(const Scope &); Index: flang/lib/Evaluate/characteristics.cpp =================================================================== --- flang/lib/Evaluate/characteristics.cpp +++ flang/lib/Evaluate/characteristics.cpp @@ -73,24 +73,26 @@ } std::optional TypeAndShape::Characterize( - const semantics::Symbol &symbol, FoldingContext &context) { + const semantics::Symbol &symbol, FoldingContext &context, + bool invariantOnly) { const auto &ultimate{symbol.GetUltimate()}; return common::visit( common::visitors{ [&](const semantics::ProcEntityDetails &proc) { if (proc.procInterface()) { - return Characterize(*proc.procInterface(), context); + return Characterize( + *proc.procInterface(), context, invariantOnly); } else if (proc.type()) { - return Characterize(*proc.type(), context); + return Characterize(*proc.type(), context, invariantOnly); } else { return std::optional{}; } }, [&](const semantics::AssocEntityDetails &assoc) { - return Characterize(assoc, context); + return Characterize(assoc, context, invariantOnly); }, [&](const semantics::ProcBindingDetails &binding) { - return Characterize(binding.symbol(), context); + return Characterize(binding.symbol(), context, invariantOnly); }, [&](const auto &x) -> std::optional { using Ty = std::decay_t; @@ -99,8 +101,8 @@ std::is_same_v) { if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) { if (auto dyType{DynamicType::From(*type)}) { - TypeAndShape result{ - std::move(*dyType), GetShape(context, ultimate)}; + TypeAndShape result{std::move(*dyType), + GetShape(context, ultimate, invariantOnly)}; result.AcquireAttrs(ultimate); result.AcquireLEN(ultimate); return std::move(result.Rewrite(context)); @@ -117,14 +119,15 @@ } std::optional TypeAndShape::Characterize( - const semantics::AssocEntityDetails &assoc, FoldingContext &context) { + const semantics::AssocEntityDetails &assoc, FoldingContext &context, + bool invariantOnly) { std::optional result; if (auto type{DynamicType::From(assoc.type())}) { if (auto rank{assoc.rank()}) { if (*rank >= 0 && *rank <= common::maxRank) { result = TypeAndShape{std::move(*type), Shape(*rank)}; } - } else if (auto shape{GetShape(context, assoc.expr())}) { + } else if (auto shape{GetShape(context, assoc.expr(), invariantOnly)}) { result = TypeAndShape{std::move(*type), std::move(*shape)}; } if (result && type->category() == TypeCategory::Character) { @@ -139,7 +142,8 @@ } std::optional TypeAndShape::Characterize( - const semantics::DeclTypeSpec &spec, FoldingContext &context) { + const semantics::DeclTypeSpec &spec, FoldingContext &context, + bool /*invariantOnly=*/) { if (auto type{DynamicType::From(spec)}) { return Fold(context, TypeAndShape{std::move(*type)}); } else { @@ -148,11 +152,11 @@ } std::optional TypeAndShape::Characterize( - const ActualArgument &arg, FoldingContext &context) { + const ActualArgument &arg, FoldingContext &context, bool invariantOnly) { if (const auto *expr{arg.UnwrapExpr()}) { - return Characterize(*expr, context); + return Characterize(*expr, context, invariantOnly); } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) { - return Characterize(*assumed, context); + return Characterize(*assumed, context, invariantOnly); } else { return std::nullopt; } @@ -386,7 +390,8 @@ const semantics::Symbol &symbol, FoldingContext &context) { if (const auto *object{symbol.detailsIf()}; object || symbol.has()) { - if (auto type{TypeAndShape::Characterize(symbol, context)}) { + if (auto type{TypeAndShape::Characterize( + symbol, context, /*invariantOnly=*/false)}) { std::optional result{std::move(*type)}; using semantics::Attr; CopyAttrs(symbol, *result, @@ -525,7 +530,6 @@ static std::optional CharacterizeProcedure( const semantics::Symbol &original, FoldingContext &context, semantics::UnorderedSymbolSet seenProcs) { - Procedure result; const auto &symbol{ResolveAssociations(original)}; if (seenProcs.find(symbol) != seenProcs.end()) { std::string procsList{GetSeenProcs(seenProcs)}; @@ -536,22 +540,11 @@ return std::nullopt; } seenProcs.insert(symbol); - if (IsElementalProcedure(symbol)) { - result.attrs.set(Procedure::Attr::Elemental); - } - CopyAttrs(symbol, result, - { - {semantics::Attr::BIND_C, Procedure::Attr::BindC}, - }); - if (IsPureProcedure(symbol) || // works for ENTRY too - (!symbol.attrs().test(semantics::Attr::IMPURE) && - result.attrs.test(Procedure::Attr::Elemental))) { - result.attrs.set(Procedure::Attr::Pure); - } - return common::visit( + auto result{common::visit( common::visitors{ [&](const semantics::SubprogramDetails &subp) -> std::optional { + Procedure result; if (subp.isFunction()) { if (auto fr{CharacterizeFunctionResult( subp.result(), context, seenProcs)}) { @@ -578,7 +571,7 @@ } } result.cudaSubprogramAttrs = subp.cudaSubprogramAttrs(); - return result; + return std::move(result); }, [&](const semantics::ProcEntityDetails &proc) -> std::optional { @@ -597,14 +590,17 @@ } if (const semantics::Symbol * interfaceSymbol{proc.procInterface()}) { - auto interface { - CharacterizeProcedure(*interfaceSymbol, context, seenProcs) - }; - if (interface && IsPointer(symbol)) { - interface->attrs.reset(Procedure::Attr::Elemental); + auto result{ + CharacterizeProcedure(*interfaceSymbol, context, seenProcs)}; + if (result && (IsDummy(symbol) || IsPointer(symbol))) { + // Dummy procedures and procedure pointers may not be + // ELEMENTAL, but we do accept the use of elemental intrinsic + // functions as their interfaces. + result->attrs.reset(Procedure::Attr::Elemental); } - return interface; + return result; } else { + Procedure result; result.attrs.set(Procedure::Attr::ImplicitInterface); const semantics::DeclTypeSpec *type{proc.type()}; if (symbol.test(semantics::Symbol::Flag::Subroutine)) { @@ -624,7 +620,7 @@ return std::nullopt; } // The PASS name, if any, is not a characteristic. - return result; + return std::move(result); } }, [&](const semantics::ProcBindingDetails &binding) { @@ -683,7 +679,20 @@ return std::optional{}; }, }, - symbol.details()); + symbol.details())}; + if (result && !symbol.has()) { + CopyAttrs(DEREF(GetMainEntry(&symbol)), *result, + { + {semantics::Attr::BIND_C, Procedure::Attr::BindC}, + {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental}, + }); + if (IsPureProcedure(symbol) || // works for ENTRY too + (!IsExplicitlyImpureProcedure(symbol) && + result->attrs.test(Procedure::Attr::Elemental))) { + result->attrs.set(Procedure::Attr::Pure); + } + } + return result; } static std::optional CharacterizeDummyProcedure( @@ -918,7 +927,8 @@ const semantics::Symbol &symbol, FoldingContext &context, semantics::UnorderedSymbolSet seenProcs) { if (const auto *object{symbol.detailsIf()}) { - if (auto type{TypeAndShape::Characterize(symbol, context)}) { + if (auto type{TypeAndShape::Characterize( + symbol, context, /*invariantOnly=*/false)}) { FunctionResult result{std::move(*type)}; CopyAttrs(symbol, result, { @@ -996,21 +1006,18 @@ } } -static bool AreCompatibleFunctionResultShapes(const Shape &x, const Shape &y) { +static std::optional AreIncompatibleFunctionResultShapes( + const Shape &x, const Shape &y) { int rank{GetRank(x)}; - if (GetRank(y) != rank) { - return false; + if (int yrank{GetRank(y)}; yrank != rank) { + return "rank "s + std::to_string(rank) + " vs " + std::to_string(yrank); } for (int j{0}; j < rank; ++j) { - if (auto xDim{ToInt64(x[j])}) { - if (auto yDim{ToInt64(y[j])}) { - if (*xDim != *yDim) { - return false; - } - } + if (x[j] && y[j] && !(*x[j] == *y[j])) { + return x[j]->AsFortran() + " vs " + y[j]->AsFortran(); } } - return true; + return std::nullopt; } bool FunctionResult::IsCompatibleWith( @@ -1029,38 +1036,45 @@ } } else if (const auto *ifaceTypeShape{std::get_if(&u)}) { if (const auto *actualTypeShape{std::get_if(&actual.u)}) { + std::optional details; if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) { if (whyNot) { *whyNot = "function results have distinct ranks"; } } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) && - !AreCompatibleFunctionResultShapes( - ifaceTypeShape->shape(), actualTypeShape->shape())) { + (details = AreIncompatibleFunctionResultShapes( + ifaceTypeShape->shape(), actualTypeShape->shape()))) { if (whyNot) { - *whyNot = "function results have distinct constant extents"; + *whyNot = "function results have distinct extents (" + *details + ')'; } } else if (ifaceTypeShape->type() != actualTypeShape->type()) { - if (ifaceTypeShape->type().category() == + if (ifaceTypeShape->type().category() != actualTypeShape->type().category()) { - if (ifaceTypeShape->type().category() == TypeCategory::Character) { - if (ifaceTypeShape->type().kind() == - actualTypeShape->type().kind()) { - auto ifaceLen{ifaceTypeShape->type().knownLength()}; - auto actualLen{actualTypeShape->type().knownLength()}; - if (!ifaceLen || !actualLen || *ifaceLen == *actualLen) { + } else if (ifaceTypeShape->type().category() == + TypeCategory::Character) { + if (ifaceTypeShape->type().kind() == actualTypeShape->type().kind()) { + if (IsAssumedLengthCharacter() || + actual.IsAssumedLengthCharacter()) { + return true; + } else { + const auto *ifaceLenParam{ + ifaceTypeShape->type().charLengthParamValue()}; + const auto *actualLenParam{ + actualTypeShape->type().charLengthParamValue()}; + if (ifaceLenParam && actualLenParam && + *ifaceLenParam == *actualLenParam) { return true; } } - } else if (ifaceTypeShape->type().category() == - TypeCategory::Derived) { - if (ifaceTypeShape->type().IsPolymorphic() == - actualTypeShape->type().IsPolymorphic() && - !ifaceTypeShape->type().IsUnlimitedPolymorphic() && - !actualTypeShape->type().IsUnlimitedPolymorphic() && - AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(), - actualTypeShape->type().GetDerivedTypeSpec())) { - return true; - } + } + } else if (ifaceTypeShape->type().category() == TypeCategory::Derived) { + if (ifaceTypeShape->type().IsPolymorphic() == + actualTypeShape->type().IsPolymorphic() && + !ifaceTypeShape->type().IsUnlimitedPolymorphic() && + !actualTypeShape->type().IsUnlimitedPolymorphic() && + AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(), + actualTypeShape->type().GetDerivedTypeSpec())) { + return true; } } if (whyNot) { Index: flang/lib/Evaluate/intrinsics.cpp =================================================================== --- flang/lib/Evaluate/intrinsics.cpp +++ flang/lib/Evaluate/intrinsics.cpp @@ -3023,7 +3023,7 @@ } if (!ok) { context.messages().Say(at, - "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional"_err_en_US); + "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US); } else if (data[0]->attrs.test(characteristics::DummyDataObject:: Attr::Asynchronous) != data[1]->attrs.test( Index: flang/lib/Evaluate/shape.cpp =================================================================== --- flang/lib/Evaluate/shape.cpp +++ flang/lib/Evaluate/shape.cpp @@ -76,10 +76,10 @@ } } -Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) { +Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) const { Shape shape; for (int dimension{0}; dimension < rank; ++dimension) { - shape.emplace_back(GetExtent(base, dimension)); + shape.emplace_back(GetExtent(base, dimension, invariantOnly_)); } return shape; } @@ -236,8 +236,10 @@ using Result = RESULT; using Base = Traverse; using Base::operator(); - explicit GetLowerBoundHelper(int d, FoldingContext *context) - : Base{*this}, dimension_{d}, context_{context} {} + explicit GetLowerBoundHelper( + int d, FoldingContext *context, bool invariantOnly) + : Base{*this}, dimension_{d}, context_{context}, invariantOnly_{ + invariantOnly} {} static Result Default() { return Result{1}; } static Result Combine(Result &&, Result &&) { // Operator results and array references always have lower bounds == 1 @@ -259,7 +261,7 @@ if (dimension_ == rank - 1 && details->IsAssumedSize()) { // last dimension of assumed-size dummy array: don't worry // about handling an empty dimension - ok = IsScopeInvariantExpr(*lbound); + ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound); } else if (lbValue.value_or(0) == 1) { // Lower bound is 1, regardless of extent ok = true; @@ -371,60 +373,69 @@ private: int dimension_; // zero-based FoldingContext *context_{nullptr}; + bool invariantOnly_{false}; }; -ExtentExpr GetRawLowerBound(const NamedEntity &base, int dimension) { - return GetLowerBoundHelper{dimension, nullptr}(base); +ExtentExpr GetRawLowerBound( + const NamedEntity &base, int dimension, bool invariantOnly) { + return GetLowerBoundHelper{ + dimension, nullptr, invariantOnly}(base); } -ExtentExpr GetRawLowerBound( - FoldingContext &context, const NamedEntity &base, int dimension) { +ExtentExpr GetRawLowerBound(FoldingContext &context, const NamedEntity &base, + int dimension, bool invariantOnly) { return Fold(context, - GetLowerBoundHelper{dimension, &context}(base)); + GetLowerBoundHelper{ + dimension, &context, invariantOnly}(base)); } -MaybeExtentExpr GetLBOUND(const NamedEntity &base, int dimension) { - return GetLowerBoundHelper{dimension, nullptr}(base); +MaybeExtentExpr GetLBOUND( + const NamedEntity &base, int dimension, bool invariantOnly) { + return GetLowerBoundHelper{ + dimension, nullptr, invariantOnly}(base); } -MaybeExtentExpr GetLBOUND( - FoldingContext &context, const NamedEntity &base, int dimension) { +MaybeExtentExpr GetLBOUND(FoldingContext &context, const NamedEntity &base, + int dimension, bool invariantOnly) { return Fold(context, - GetLowerBoundHelper{dimension, &context}(base)); + GetLowerBoundHelper{ + dimension, &context, invariantOnly}(base)); } -Shape GetRawLowerBounds(const NamedEntity &base) { +Shape GetRawLowerBounds(const NamedEntity &base, bool invariantOnly) { Shape result; int rank{base.Rank()}; for (int dim{0}; dim < rank; ++dim) { - result.emplace_back(GetRawLowerBound(base, dim)); + result.emplace_back(GetRawLowerBound(base, dim, invariantOnly)); } return result; } -Shape GetRawLowerBounds(FoldingContext &context, const NamedEntity &base) { +Shape GetRawLowerBounds( + FoldingContext &context, const NamedEntity &base, bool invariantOnly) { Shape result; int rank{base.Rank()}; for (int dim{0}; dim < rank; ++dim) { - result.emplace_back(GetRawLowerBound(context, base, dim)); + result.emplace_back(GetRawLowerBound(context, base, dim, invariantOnly)); } return result; } -Shape GetLBOUNDs(const NamedEntity &base) { +Shape GetLBOUNDs(const NamedEntity &base, bool invariantOnly) { Shape result; int rank{base.Rank()}; for (int dim{0}; dim < rank; ++dim) { - result.emplace_back(GetLBOUND(base, dim)); + result.emplace_back(GetLBOUND(base, dim, invariantOnly)); } return result; } -Shape GetLBOUNDs(FoldingContext &context, const NamedEntity &base) { +Shape GetLBOUNDs( + FoldingContext &context, const NamedEntity &base, bool invariantOnly) { Shape result; int rank{base.Rank()}; for (int dim{0}; dim < rank; ++dim) { - result.emplace_back(GetLBOUND(context, base, dim)); + result.emplace_back(GetLBOUND(context, base, dim, invariantOnly)); } return result; } @@ -433,7 +444,7 @@ // the extent. In particular, if the upper bound is less than the lower bound, // return zero. static MaybeExtentExpr GetNonNegativeExtent( - const semantics::ShapeSpec &shapeSpec) { + const semantics::ShapeSpec &shapeSpec, bool invariantOnly) { const auto &ubound{shapeSpec.ubound().GetExplicit()}; const auto &lbound{shapeSpec.lbound().GetExplicit()}; std::optional uval{ToInt64(ubound)}; @@ -444,8 +455,9 @@ } else { return ExtentExpr{*uval - *lval + 1}; } - } else if (lbound && ubound && IsScopeInvariantExpr(*lbound) && - IsScopeInvariantExpr(*ubound)) { + } else if (lbound && ubound && + (!invariantOnly || + (IsScopeInvariantExpr(*lbound) && IsScopeInvariantExpr(*ubound)))) { // Apply effective IDIM (MAX calculation with 0) so thet the // result is never negative if (lval.value_or(0) == 1) { @@ -481,7 +493,8 @@ return std::nullopt; } -MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) { +MaybeExtentExpr GetExtent( + const NamedEntity &base, int dimension, bool invariantOnly) { CHECK(dimension >= 0); const Symbol &last{base.GetLastSymbol()}; const Symbol &symbol{ResolveAssociationsExceptSelectRank(last)}; @@ -506,7 +519,7 @@ int j{0}; for (const auto &shapeSpec : details->shape()) { if (j++ == dimension) { - if (auto extent{GetNonNegativeExtent(shapeSpec)}) { + if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) { return extent; } else if (details->IsAssumedSize() && j == symbol.Rank()) { return std::nullopt; @@ -523,23 +536,23 @@ return std::nullopt; } -MaybeExtentExpr GetExtent( - FoldingContext &context, const NamedEntity &base, int dimension) { - return Fold(context, GetExtent(base, dimension)); +MaybeExtentExpr GetExtent(FoldingContext &context, const NamedEntity &base, + int dimension, bool invariantOnly) { + return Fold(context, GetExtent(base, dimension, invariantOnly)); } -MaybeExtentExpr GetExtent( - const Subscript &subscript, const NamedEntity &base, int dimension) { +MaybeExtentExpr GetExtent(const Subscript &subscript, const NamedEntity &base, + int dimension, bool invariantOnly) { return common::visit( common::visitors{ [&](const Triplet &triplet) -> MaybeExtentExpr { MaybeExtentExpr upper{triplet.upper()}; if (!upper) { - upper = GetUBOUND(base, dimension); + upper = GetUBOUND(base, dimension, invariantOnly); } MaybeExtentExpr lower{triplet.lower()}; if (!lower) { - lower = GetLBOUND(base, dimension); + lower = GetLBOUND(base, dimension, invariantOnly); } return CountTrips(std::move(lower), std::move(upper), MaybeExtentExpr{triplet.stride()}); @@ -558,8 +571,8 @@ } MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript, - const NamedEntity &base, int dimension) { - return Fold(context, GetExtent(subscript, base, dimension)); + const NamedEntity &base, int dimension, bool invariantOnly) { + return Fold(context, GetExtent(subscript, base, dimension, invariantOnly)); } MaybeExtentExpr ComputeUpperBound( @@ -580,14 +593,15 @@ return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent))); } -MaybeExtentExpr GetRawUpperBound(const NamedEntity &base, int dimension) { +MaybeExtentExpr GetRawUpperBound( + const NamedEntity &base, int dimension, bool invariantOnly) { const Symbol &symbol{ ResolveAssociationsExceptSelectRank(base.GetLastSymbol())}; if (const auto *details{symbol.detailsIf()}) { int rank{details->shape().Rank()}; if (dimension < rank) { const auto &bound{details->shape()[dimension].ubound().GetExplicit()}; - if (bound && IsScopeInvariantExpr(*bound)) { + if (bound && (!invariantOnly || IsScopeInvariantExpr(*bound))) { return *bound; } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) { return std::nullopt; @@ -606,16 +620,16 @@ return std::nullopt; } -MaybeExtentExpr GetRawUpperBound( - FoldingContext &context, const NamedEntity &base, int dimension) { - return Fold(context, GetRawUpperBound(base, dimension)); +MaybeExtentExpr GetRawUpperBound(FoldingContext &context, + const NamedEntity &base, int dimension, bool invariantOnly) { + return Fold(context, GetRawUpperBound(base, dimension, invariantOnly)); } -static MaybeExtentExpr GetExplicitUBOUND( - FoldingContext *context, const semantics::ShapeSpec &shapeSpec) { +static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context, + const semantics::ShapeSpec &shapeSpec, bool invariantOnly) { const auto &ubound{shapeSpec.ubound().GetExplicit()}; - if (ubound && IsScopeInvariantExpr(*ubound)) { - if (auto extent{GetNonNegativeExtent(shapeSpec)}) { + if (ubound && (!invariantOnly || IsScopeInvariantExpr(*ubound))) { + if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) { if (auto cstExtent{ToInt64( context ? Fold(*context, std::move(*extent)) : *extent)}) { if (cstExtent > 0) { @@ -629,20 +643,21 @@ return std::nullopt; } -static MaybeExtentExpr GetUBOUND( - FoldingContext *context, const NamedEntity &base, int dimension) { +static MaybeExtentExpr GetUBOUND(FoldingContext *context, + const NamedEntity &base, int dimension, bool invariantOnly) { const Symbol &symbol{ ResolveAssociationsExceptSelectRank(base.GetLastSymbol())}; if (const auto *details{symbol.detailsIf()}) { int rank{details->shape().Rank()}; if (dimension < rank) { const semantics::ShapeSpec &shapeSpec{details->shape()[dimension]}; - if (auto ubound{GetExplicitUBOUND(context, shapeSpec)}) { + if (auto ubound{GetExplicitUBOUND(context, shapeSpec, invariantOnly)}) { return *ubound; } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) { return std::nullopt; // UBOUND() folding replaces with -1 - } else if (auto lb{GetLBOUND(base, dimension)}) { - return ComputeUpperBound(std::move(*lb), GetExtent(base, dimension)); + } else if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) { + return ComputeUpperBound( + std::move(*lb), GetExtent(base, dimension, invariantOnly)); } } } else if (const auto *assoc{ @@ -658,7 +673,7 @@ } } else if (assoc->expr()) { if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) { - if (auto lb{GetLBOUND(base, dimension)}) { + if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) { return ComputeUpperBound(std::move(*lb), std::move(extent)); } } @@ -667,29 +682,34 @@ return std::nullopt; } -MaybeExtentExpr GetUBOUND(const NamedEntity &base, int dimension) { - return GetUBOUND(nullptr, base, dimension); +MaybeExtentExpr GetUBOUND( + const NamedEntity &base, int dimension, bool invariantOnly) { + return GetUBOUND(nullptr, base, dimension, invariantOnly); } -MaybeExtentExpr GetUBOUND( - FoldingContext &context, const NamedEntity &base, int dimension) { - return Fold(context, GetUBOUND(&context, base, dimension)); +MaybeExtentExpr GetUBOUND(FoldingContext &context, const NamedEntity &base, + int dimension, bool invariantOnly) { + return Fold(context, GetUBOUND(&context, base, dimension, invariantOnly)); } -static Shape GetUBOUNDs(FoldingContext *context, const NamedEntity &base) { +static Shape GetUBOUNDs( + FoldingContext *context, const NamedEntity &base, bool invariantOnly) { Shape result; int rank{base.Rank()}; for (int dim{0}; dim < rank; ++dim) { - result.emplace_back(GetUBOUND(context, base, dim)); + result.emplace_back(GetUBOUND(context, base, dim, invariantOnly)); } return result; } -Shape GetUBOUNDs(FoldingContext &context, const NamedEntity &base) { - return Fold(context, GetUBOUNDs(&context, base)); +Shape GetUBOUNDs( + FoldingContext &context, const NamedEntity &base, bool invariantOnly) { + return Fold(context, GetUBOUNDs(&context, base, invariantOnly)); } -Shape GetUBOUNDs(const NamedEntity &base) { return GetUBOUNDs(nullptr, base); } +Shape GetUBOUNDs(const NamedEntity &base, bool invariantOnly) { + return GetUBOUNDs(nullptr, base, invariantOnly); +} auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result { return common::visit( Index: flang/lib/Evaluate/tools.cpp =================================================================== --- flang/lib/Evaluate/tools.cpp +++ flang/lib/Evaluate/tools.cpp @@ -1323,23 +1323,26 @@ return symbol && IsPureProcedure(*symbol); } +bool IsExplicitlyImpureProcedure(const Symbol &original) { + // An ENTRY is IMPURE if its containing subprogram is so + return DEREF(GetMainEntry(&original.GetUltimate())) + .attrs() + .test(Attr::IMPURE); +} + bool IsElementalProcedure(const Symbol &original) { // An ENTRY is elemental if its containing subprogram is const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))}; - if (const auto *procDetails{symbol.detailsIf()}) { - if (const Symbol * procInterface{procDetails->procInterface()}) { - // procedure with an elemental interface, ignoring the elemental - // aspect of intrinsic functions - return !procInterface->attrs().test(Attr::INTRINSIC) && - IsElementalProcedure(*procInterface); - } - } else if (const auto *details{symbol.detailsIf()}) { - return !details->symbol().attrs().test(Attr::INTRINSIC) && - IsElementalProcedure(details->symbol()); - } else if (!IsProcedure(symbol)) { + if (IsProcedure(symbol)) { + auto &foldingContext{symbol.owner().context().foldingContext()}; + auto restorer{foldingContext.messages().DiscardMessages()}; + auto proc{evaluate::characteristics::Procedure::Characterize( + symbol, foldingContext)}; + return proc && + proc->attrs.test(evaluate::characteristics::Procedure::Attr::Elemental); + } else { return false; } - return symbol.attrs().test(Attr::ELEMENTAL); } bool IsFunction(const Symbol &symbol) { Index: flang/lib/Evaluate/variable.cpp =================================================================== --- flang/lib/Evaluate/variable.cpp +++ flang/lib/Evaluate/variable.cpp @@ -639,16 +639,32 @@ // For the purposes of comparing type parameter expressions while // testing the compatibility of procedure characteristics, two -// object dummy arguments with the same name are considered equal. +// dummy arguments with the same position are considered equal. +static std::optional GetDummyArgPosition(const Symbol &original) { + const Symbol &symbol(original.GetUltimate()); + if (IsDummy(symbol)) { + if (const Symbol * proc{symbol.owner().symbol()}) { + if (const auto *subp{proc->detailsIf()}) { + int j{0}; + for (const Symbol *arg : subp->dummyArgs()) { + if (arg == &symbol) { + return j; + } + ++j; + } + } + } + } + return std::nullopt; +} + static bool AreSameSymbol(const Symbol &x, const Symbol &y) { if (&x == &y) { return true; } - if (x.name() == y.name()) { - if (const auto *xObject{x.detailsIf()}) { - if (const auto *yObject{y.detailsIf()}) { - return xObject->isDummy() && yObject->isDummy(); - } + if (auto xPos{GetDummyArgPosition(x)}) { + if (auto yPos{GetDummyArgPosition(y)}) { + return *xPos == *yPos; } } return false; Index: flang/lib/Lower/ConvertType.cpp =================================================================== --- flang/lib/Lower/ConvertType.cpp +++ flang/lib/Lower/ConvertType.cpp @@ -276,8 +276,8 @@ Fortran::semantics::IsUnlimitedPolymorphic(symbol)) && !Fortran::semantics::IsAssumedType(symbol); if (ultimate.IsObjectArray()) { - auto shapeExpr = Fortran::evaluate::GetShapeHelper{ - converter.getFoldingContext()}(ultimate); + auto shapeExpr = + Fortran::evaluate::GetShape(converter.getFoldingContext(), ultimate); if (!shapeExpr) TODO(loc, "assumed rank symbol type"); fir::SequenceType::Shape shape; Index: flang/lib/Semantics/check-declarations.cpp =================================================================== --- flang/lib/Semantics/check-declarations.cpp +++ flang/lib/Semantics/check-declarations.cpp @@ -1024,7 +1024,7 @@ if (auto designator{evaluate::AsGenericExpr(symbol)}) { auto restorer{messages_.SetLocation(symbol.name())}; context_.set_location(symbol.name()); - CheckInitialTarget( + CheckInitialDataPointerTarget( context_, *designator, *object->init(), DEREF(scope_)); } } @@ -1033,28 +1033,36 @@ // C1519 - must be nonelemental external or module procedure, // or an unrestricted specific intrinsic function. const Symbol &ultimate{(*proc->init())->GetUltimate()}; + bool checkTarget{true}; if (ultimate.attrs().test(Attr::INTRINSIC)) { - if (const auto intrinsic{ - context_.intrinsics().IsSpecificIntrinsicFunction( - ultimate.name().ToString())}; + if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction( + ultimate.name().ToString())}; !intrinsic || intrinsic->isRestrictedSpecific) { // C1030 context_.Say( "Intrinsic procedure '%s' is not an unrestricted specific " "intrinsic permitted for use as the initializer for procedure " "pointer '%s'"_err_en_US, ultimate.name(), symbol.name()); + checkTarget = false; } - } else if (!ultimate.attrs().test(Attr::EXTERNAL) && - ultimate.owner().kind() != Scope::Kind::Module) { + } else if ((!ultimate.attrs().test(Attr::EXTERNAL) && + ultimate.owner().kind() != Scope::Kind::Module) || + IsDummy(ultimate) || IsPointer(ultimate)) { context_.Say("Procedure pointer '%s' initializer '%s' is neither " "an external nor a module procedure"_err_en_US, symbol.name(), ultimate.name()); + checkTarget = false; } else if (IsElementalProcedure(ultimate)) { context_.Say("Procedure pointer '%s' cannot be initialized with the " - "elemental procedure '%s"_err_en_US, + "elemental procedure '%s'"_err_en_US, symbol.name(), ultimate.name()); - } else { - // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10. + checkTarget = false; + } + if (checkTarget) { + SomeExpr lhs{evaluate::ProcedureDesignator{symbol}}; + SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}}; + CheckPointerAssignment(context_, lhs, rhs, + GetProgramUnitOrBlockConstructContaining(symbol)); } } } @@ -1148,6 +1156,9 @@ void CheckHelper::CheckProcEntity( const Symbol &symbol, const ProcEntityDetails &details) { CheckSymbolType(symbol); + const Symbol *interface { + details.procInterface() ? &details.procInterface()->GetUltimate() : nullptr + }; if (details.isDummy()) { if (!symbol.attrs().test(Attr::POINTER) && // C843 (symbol.attrs().test(Attr::INTENT_IN) || @@ -1160,20 +1171,19 @@ messages_.Say( "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US); } - const Symbol *interface { - details.procInterface() - }; - if (!symbol.attrs().test(Attr::INTRINSIC) && - (IsElementalProcedure(symbol) || - (interface && !interface->attrs().test(Attr::INTRINSIC) && - IsElementalProcedure(*interface)))) { + if (interface && IsElementalProcedure(*interface)) { // There's no explicit constraint or "shall" that we can find in the // standard for this check, but it seems to be implied in multiple // sites, and ELEMENTAL non-intrinsic actual arguments *are* // explicitly forbidden. But we allow "PROCEDURE(SIN)::dummy" // because it is explicitly legal to *pass* the specific intrinsic // function SIN as an actual argument. - messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); + if (interface->attrs().test(Attr::INTRINSIC)) { + messages_.Say( + "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US); + } else { + messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); + } } } else if (symbol.attrs().test(Attr::INTENT_IN) || symbol.attrs().test(Attr::INTENT_OUT) || @@ -1183,35 +1193,35 @@ } else if (IsOptional(symbol)) { messages_.Say("OPTIONAL attribute may apply only to a dummy " "argument"_err_en_US); // C849 - } else if (symbol.owner().IsDerivedType()) { - if (!symbol.attrs().test(Attr::POINTER)) { // C756 - const auto &name{symbol.name()}; - messages_.Say(name, - "Procedure component '%s' must have POINTER attribute"_err_en_US, - name); - } - CheckPassArg(symbol, details.procInterface(), details); - } - if (IsPointer(symbol)) { + } else if (IsPointer(symbol)) { CheckPointerInitialization(symbol); - if (const Symbol * interface{details.procInterface()}) { - const Symbol &ultimate{interface->GetUltimate()}; - if (ultimate.attrs().test(Attr::INTRINSIC)) { - if (const auto intrinsic{ - context_.intrinsics().IsSpecificIntrinsicFunction( - ultimate.name().ToString())}; - !intrinsic || intrinsic->isRestrictedSpecific) { // C1515 + if (interface) { + if (interface->attrs().test(Attr::INTRINSIC)) { + auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction( + interface->name().ToString())}; + if (!intrinsic || intrinsic->isRestrictedSpecific) { // C1515 messages_.Say( "Intrinsic procedure '%s' is not an unrestricted specific " "intrinsic permitted for use as the definition of the interface " "to procedure pointer '%s'"_err_en_US, - ultimate.name(), symbol.name()); + interface->name(), symbol.name()); + } else if (IsElementalProcedure(*interface)) { + messages_.Say( + "Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US, + symbol.name()); // C1517 } } else if (IsElementalProcedure(*interface)) { messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US, symbol.name()); // C1517 } } + if (symbol.owner().IsDerivedType()) { + CheckPassArg(symbol, interface, details); + } + } else if (symbol.owner().IsDerivedType()) { + const auto &name{symbol.name()}; + messages_.Say(name, + "Procedure component '%s' must have POINTER attribute"_err_en_US, name); } CheckExternal(symbol); } Index: flang/lib/Semantics/data-to-inits.cpp =================================================================== --- flang/lib/Semantics/data-to-inits.cpp +++ flang/lib/Semantics/data-to-inits.cpp @@ -406,7 +406,7 @@ exprAnalyzer_.Say( "Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US, expr->AsFortran(), DescribeElement()); - } else if (CheckInitialTarget( + } else if (CheckInitialDataPointerTarget( exprAnalyzer_.context(), designator, *expr, DEREF(scope_))) { GetImage().AddPointer(offsetSymbol.offset(), *expr); return true; Index: flang/lib/Semantics/pointer-assignment.h =================================================================== --- flang/lib/Semantics/pointer-assignment.h +++ flang/lib/Semantics/pointer-assignment.h @@ -27,16 +27,17 @@ SemanticsContext &, const evaluate::Assignment &, const Scope &); bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs, const SomeExpr &rhs, const Scope &, bool isBoundsRemapping = false); -bool CheckStructConstructorPointerComponent( - SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &); bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source, const std::string &description, const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs, const Scope &); +bool CheckStructConstructorPointerComponent( + SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &); + // Checks whether an expression is a valid static initializer for a // particular pointer designator. -bool CheckInitialTarget(SemanticsContext &, const SomeExpr &pointer, +bool CheckInitialDataPointerTarget(SemanticsContext &, const SomeExpr &pointer, const SomeExpr &init, const Scope &); } // namespace Fortran::semantics Index: flang/lib/Semantics/pointer-assignment.cpp =================================================================== --- flang/lib/Semantics/pointer-assignment.cpp +++ flang/lib/Semantics/pointer-assignment.cpp @@ -360,7 +360,8 @@ } bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) { - if (const Symbol * symbol{d.GetSymbol()}) { + const Symbol *symbol{d.GetSymbol()}; + if (symbol) { if (const auto *subp{ symbol->GetUltimate().detailsIf()}) { if (subp->stmtFunction()) { @@ -377,6 +378,10 @@ } } if (auto chars{Procedure::Characterize(d, foldingContext_)}) { + // Disregard the elemental attribute of RHS intrinsics. + if (symbol && symbol->GetUltimate().attrs().test(Attr::INTRINSIC)) { + chars->attrs.reset(Procedure::Attr::Elemental); + } return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic()); } else { return Check(d.GetName(), false); @@ -517,8 +522,8 @@ .Check(rhs); } -bool CheckInitialTarget(SemanticsContext &context, const SomeExpr &pointer, - const SomeExpr &init, const Scope &scope) { +bool CheckInitialDataPointerTarget(SemanticsContext &context, + const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) { return evaluate::IsInitialDataTarget( init, &context.foldingContext().messages()) && CheckPointerAssignment(context, pointer, init, scope); Index: flang/test/Semantics/block-data01.f90 =================================================================== --- flang/test/Semantics/block-data01.f90 +++ flang/test/Semantics/block-data01.f90 @@ -7,6 +7,7 @@ !ERROR: An initialized variable in BLOCK DATA must be in a COMMON block integer :: notInCommon = 1 integer :: uninitialized ! ok + !PORTABILITY: Procedure pointer 'q' should not have an ELEMENTAL intrinsic as its interface !ERROR: 'q' may not appear in a BLOCK DATA subprogram procedure(sin), pointer :: q => cos !ERROR: 'p' may not be a procedure as it is in a COMMON block Index: flang/test/Semantics/c_loc01.f90 =================================================================== --- flang/test/Semantics/c_loc01.f90 +++ flang/test/Semantics/c_loc01.f90 @@ -11,6 +11,7 @@ type(c_ptr) cp type(c_funptr) cfp real notATarget + !PORTABILITY: Procedure pointer 'pptr' should not have an ELEMENTAL intrinsic as its interface procedure(sin), pointer :: pptr real, target :: arr(3) type(hasLen(1)), target :: clen Index: flang/test/Semantics/call02.f90 =================================================================== --- flang/test/Semantics/call02.f90 +++ flang/test/Semantics/call02.f90 @@ -8,6 +8,7 @@ real, intent(in), value :: x end function subroutine subr(dummy) + !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface procedure(sin) :: dummy end subroutine subroutine badsubr(dummy) @@ -16,9 +17,11 @@ procedure(elem) :: dummy end subroutine subroutine optionalsubr(dummy) + !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface procedure(sin), optional :: dummy end subroutine subroutine ptrsubr(dummy) + !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface procedure(sin), pointer, intent(in) :: dummy end subroutine end interface Index: flang/test/Semantics/call09.f90 =================================================================== --- flang/test/Semantics/call09.f90 +++ flang/test/Semantics/call09.f90 @@ -37,6 +37,7 @@ end subroutine subroutine selemental1(p) + !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface procedure(cos) :: p ! ok end subroutine Index: flang/test/Semantics/io11.f90 =================================================================== --- flang/test/Semantics/io11.f90 +++ flang/test/Semantics/io11.f90 @@ -80,9 +80,10 @@ contains !ERROR: Dummy argument 0 of 'formattedreadproc' must be a data object !ERROR: Cannot use an alternate return as the passed-object dummy argument - subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg) + subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg) !ERROR: Dummy argument 'unit' must be a data object !ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute + !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface procedure(sin), intent(in) :: unit character(len=*), intent(in) :: iotype integer, intent(in) :: vlist(:) Index: flang/test/Semantics/modfile49.f90 =================================================================== --- flang/test/Semantics/modfile49.f90 +++ flang/test/Semantics/modfile49.f90 @@ -4,7 +4,11 @@ module m type :: t end type - procedure(sin) :: ext + abstract interface + subroutine iface + end + end interface + procedure(iface) :: ext interface subroutine subr(p1,p2) import ext, t @@ -22,8 +26,11 @@ !module m !type::t !end type -!intrinsic::sin -!procedure(sin)::ext +!abstract interface +!subroutine iface() +!end +!end interface +!procedure(iface)::ext !interface !subroutine subr(p1,p2) !import::ext Index: flang/test/Semantics/procinterface01.f90 =================================================================== --- flang/test/Semantics/procinterface01.f90 +++ flang/test/Semantics/procinterface01.f90 @@ -48,7 +48,7 @@ type :: derived1 !REF: /module1/abstract1 !DEF: /module1/derived1/p1 NOPASS, POINTER (Function) ProcEntity REAL(4) - !DEF: /module1/nested1 PUBLIC (Function) Subprogram REAL(4) + !DEF: /module1/nested1 PUBLIC, PURE (Function) Subprogram REAL(4) procedure(abstract1), pointer, nopass :: p1 => nested1 !REF: /module1/explicit1 !DEF: /module1/derived1/p2 NOPASS, POINTER (Function) ProcEntity REAL(4) @@ -81,7 +81,7 @@ !REF: /module1/nested1 !DEF: /module1/nested1/x INTENT(IN) ObjectEntity REAL(4) - real function nested1(x) + pure real function nested1(x) !REF: /module1/nested1/x real, intent(in) :: x !DEF: /module1/nested1/nested1 ObjectEntity REAL(4) Index: flang/test/Semantics/procinterface02.f90 =================================================================== --- flang/test/Semantics/procinterface02.f90 +++ flang/test/Semantics/procinterface02.f90 @@ -12,6 +12,7 @@ end function end interface real :: A(:), B(:) + !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface procedure(sqrt), pointer :: P !ERROR: Rank of dummy argument is 0, but actual argument has rank 1 A = P(B) Index: flang/test/Semantics/procinterface04.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/procinterface04.f90 @@ -0,0 +1,24 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +subroutine test(dp1, dp2) + intrinsic sin + interface + elemental real function elemental(x) + real, intent(in) :: x + end + pure real function nonelemental(x) + real, intent(in) :: x + end + end interface + !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface + procedure(sin) :: dp1 + !ERROR: A dummy procedure may not be ELEMENTAL + procedure(elemental) :: dp2 + !PORTABILITY: Procedure pointer 'pp1' should not have an ELEMENTAL intrinsic as its interface + procedure(sin), pointer :: pp1 + !ERROR: Procedure pointer 'pp2' may not be ELEMENTAL + procedure(elemental), pointer :: pp2 + procedure(elemental) :: pp3 ! ok, external + procedure(nonelemental), pointer :: pp4 => sin ! ok, special case + !ERROR: Procedure pointer 'pp5' cannot be initialized with the elemental procedure 'elemental' + procedure(nonelemental), pointer :: pp5 => elemental +end Index: flang/test/Semantics/reduce01.f90 =================================================================== --- flang/test/Semantics/reduce01.f90 +++ flang/test/Semantics/reduce01.f90 @@ -70,13 +70,13 @@ b = reduce(a, f4) !ERROR: OPERATION= argument of REDUCE() must have the same type as ARRAY= b = reduce(a, f5) - !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional + !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional b = reduce(a, f6) - !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional + !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional b = reduce(a, f7) - !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional + !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional b = reduce(a, f8) - !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional + !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional b = reduce(a, f9) !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute b = reduce(a, f10) Index: flang/test/Semantics/resolve114.f90 =================================================================== --- flang/test/Semantics/resolve114.f90 +++ flang/test/Semantics/resolve114.f90 @@ -34,7 +34,9 @@ subroutine s2a use m1 use m2 + !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface procedure(sin), pointer :: p1 => sin + !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface procedure(iabs), pointer :: p2 => iabs procedure(ext1), pointer :: p3 => ext1 procedure(ext2), pointer :: p4 => ext2 @@ -44,7 +46,9 @@ use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2 use m2, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2 use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2 + !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface procedure(iface1), pointer :: p1 => x1 + !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface procedure(iface2), pointer :: p2 => x2 procedure(iface3), pointer :: p3 => x3 procedure(iface4), pointer :: p4 => x4 @@ -56,7 +60,9 @@ end module subroutine s3 use m3 + !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface procedure(sin), pointer :: p1 => sin + !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface procedure(iabs), pointer :: p2 => iabs procedure(ext1), pointer :: p3 => ext1 procedure(ext2), pointer :: p4 => ext2 @@ -69,7 +75,9 @@ subroutine s4 use m4 use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2 + !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface procedure(iface1), pointer :: p1 => x1 + !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface procedure(iface2), pointer :: p2 => x2 procedure(iface3), pointer :: p3 => x3 procedure(iface4), pointer :: p4 => x4 @@ -79,8 +87,10 @@ use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2 use m2, only: x1 => tan, x2 => idim, x3 => ext2, x4 => ext1 use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2 + !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface !ERROR: Reference to 'x1' is ambiguous procedure(iface1), pointer :: p1 => x1 + !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface !ERROR: Reference to 'x2' is ambiguous procedure(iface2), pointer :: p2 => x2 !ERROR: Reference to 'x3' is ambiguous Index: flang/test/Semantics/resolve46.f90 =================================================================== --- flang/test/Semantics/resolve46.f90 +++ flang/test/Semantics/resolve46.f90 @@ -20,6 +20,7 @@ end function chrcmp end interface + !PORTABILITY: Procedure pointer 'p' should not have an ELEMENTAL intrinsic as its interface procedure(sin), pointer :: p => cos !ERROR: Intrinsic procedure 'amin0' is not an unrestricted specific intrinsic permitted for use as the definition of the interface to procedure pointer 'q' procedure(amin0), pointer :: q @@ -28,6 +29,7 @@ !ERROR: Intrinsic procedure 'llt' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 's' procedure(chrcmp), pointer :: s => llt !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 't' + !PORTABILITY: Procedure pointer 't' should not have an ELEMENTAL intrinsic as its interface procedure(cos), pointer :: t => bessel_j0 procedure(chrcmp), pointer :: u p => alog ! valid use of an unrestricted specific intrinsic Index: flang/test/Semantics/resolve59.f90 =================================================================== --- flang/test/Semantics/resolve59.f90 +++ flang/test/Semantics/resolve59.f90 @@ -114,6 +114,7 @@ end function function f5(x) result(r) real :: x + !PORTABILITY: Procedure pointer 'r' should not have an ELEMENTAL intrinsic as its interface procedure(acos), pointer :: r r => acos !ERROR: Actual argument for 'x=' may not be a procedure