diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -78,8 +78,6 @@ static std::optional Characterize( const semantics::Symbol &, FoldingContext &); - static std::optional Characterize( - const semantics::ObjectEntityDetails &, FoldingContext &); static std::optional Characterize( const semantics::ProcInterface &, FoldingContext &); static std::optional Characterize( @@ -87,26 +85,25 @@ static std::optional Characterize( const ActualArgument &, FoldingContext &); + // Handle Expr & Designator template static std::optional Characterize( const A &x, FoldingContext &context) { - if (const auto *symbol{UnwrapWholeSymbolDataRef(x)}) { + if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) { if (auto result{Characterize(*symbol, context)}) { return result; } } if (auto type{x.GetType()}) { - if (auto shape{GetShape(context, x)}) { - TypeAndShape result{*type, std::move(*shape)}; - if (type->category() == TypeCategory::Character) { - if (const auto *chExpr{UnwrapExpr>(x)}) { - if (auto length{chExpr->LEN()}) { - result.set_LEN(std::move(*length)); - } + TypeAndShape result{*type, GetShape(context, x)}; + if (type->category() == TypeCategory::Character) { + if (const auto *chExpr{UnwrapExpr>(x)}) { + if (auto length{chExpr->LEN()}) { + result.set_LEN(std::move(*length)); } } - return std::move(result.Rewrite(context)); } + return std::move(result.Rewrite(context)); } return std::nullopt; } @@ -162,8 +159,9 @@ const semantics::AssocEntityDetails &, FoldingContext &); static std::optional Characterize( const semantics::ProcEntityDetails &, FoldingContext &); - void AcquireShape(const semantics::ObjectEntityDetails &); + void AcquireAttrs(const semantics::Symbol &); void AcquireLEN(); + void AcquireLEN(const semantics::Symbol &); protected: DynamicType type_; diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -330,6 +330,22 @@ return nullptr; } +// If an expression is a whole symbol or a whole component desginator, +// extract and return that symbol, else null. +template +const Symbol *UnwrapWholeSymbolOrComponentDataRef(const A &x) { + if (auto dataRef{ExtractDataRef(x)}) { + if (const SymbolRef * p{std::get_if(&dataRef->u)}) { + return &p->get(); + } else if (const Component * c{std::get_if(&dataRef->u)}) { + if (c->base().Rank() == 0) { + return &c->GetLastSymbol(); + } + } + } + return nullptr; +} + // GetFirstSymbol(A%B%C[I]%D) -> A template const Symbol *GetFirstSymbol(const A &x) { if (auto dataRef{ExtractDataRef(x, true)}) { diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -68,17 +68,20 @@ std::optional TypeAndShape::Characterize( const semantics::Symbol &symbol, FoldingContext &context) { + const auto &ultimate{symbol.GetUltimate()}; return std::visit( common::visitors{ - [&](const semantics::ObjectEntityDetails &object) { - auto result{Characterize(object, context)}; - if (result && - result->type().category() == TypeCategory::Character) { - if (auto len{DataRef{symbol}.LEN()}) { - result->set_LEN(Fold(context, std::move(*len))); - } + [&](const semantics::ObjectEntityDetails &object) + -> std::optional { + if (auto type{DynamicType::From(object.type())}) { + TypeAndShape result{ + std::move(*type), GetShape(context, ultimate)}; + result.AcquireAttrs(ultimate); + result.AcquireLEN(ultimate); + return std::move(result.Rewrite(context)); + } else { + return std::nullopt; } - return result; }, [&](const semantics::ProcEntityDetails &proc) { const semantics::ProcInterface &interface{proc.interface()}; @@ -108,18 +111,7 @@ // GetUltimate() used here, not ResolveAssociations(), because // we need the type/rank of an associate entity from TYPE IS, // CLASS IS, or RANK statement. - symbol.GetUltimate().details()); -} - -std::optional TypeAndShape::Characterize( - const semantics::ObjectEntityDetails &object, FoldingContext &context) { - if (auto type{DynamicType::From(object.type())}) { - TypeAndShape result{std::move(*type)}; - result.AcquireShape(object); - return Fold(context, std::move(result)); - } else { - return std::nullopt; - } + ultimate.details()); } std::optional TypeAndShape::Characterize( @@ -196,35 +188,24 @@ return std::nullopt; } -void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) { - CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank)); - corank_ = object.coshape().Rank(); - if (object.IsAssumedRank()) { - attrs_.set(Attr::AssumedRank); - return; - } - if (object.IsAssumedShape()) { - attrs_.set(Attr::AssumedShape); - } - if (object.IsAssumedSize()) { - attrs_.set(Attr::AssumedSize); - } - if (object.IsDeferredShape()) { - attrs_.set(Attr::DeferredShape); - } - if (object.IsCoarray()) { - attrs_.set(Attr::Coarray); - } - for (const semantics::ShapeSpec &dim : object.shape()) { - if (dim.ubound().GetExplicit()) { - Expr extent{*dim.ubound().GetExplicit()}; - if (auto lbound{dim.lbound().GetExplicit()}) { - extent = - std::move(extent) + Expr{1} - std::move(*lbound); - } - shape_.emplace_back(std::move(extent)); - } else { - shape_.push_back(std::nullopt); +void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) { + if (const auto *object{ + symbol.GetUltimate().detailsIf()}) { + corank_ = object->coshape().Rank(); + if (object->IsAssumedRank()) { + attrs_.set(Attr::AssumedRank); + } + if (object->IsAssumedShape()) { + attrs_.set(Attr::AssumedShape); + } + if (object->IsAssumedSize()) { + attrs_.set(Attr::AssumedSize); + } + if (object->IsDeferredShape()) { + attrs_.set(Attr::DeferredShape); + } + if (object->IsCoarray()) { + attrs_.set(Attr::Coarray); } } } @@ -239,6 +220,14 @@ } } +void TypeAndShape::AcquireLEN(const semantics::Symbol &symbol) { + if (type_.category() == TypeCategory::Character) { + if (auto len{DataRef{symbol}.LEN()}) { + LEN_ = std::move(*len); + } + } +} + llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const { o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""); attrs_.Dump(o, EnumToString); @@ -278,8 +267,8 @@ std::optional DummyDataObject::Characterize( const semantics::Symbol &symbol, FoldingContext &context) { - if (const auto *obj{symbol.detailsIf()}) { - if (auto type{TypeAndShape::Characterize(*obj, context)}) { + if (symbol.has()) { + if (auto type{TypeAndShape::Characterize(symbol, context)}) { std::optional result{std::move(*type)}; using semantics::Attr; CopyAttrs(symbol, *result, @@ -522,8 +511,8 @@ std::optional FunctionResult::Characterize( const Symbol &symbol, FoldingContext &context) { - if (const auto *object{symbol.detailsIf()}) { - if (auto type{TypeAndShape::Characterize(*object, context)}) { + if (symbol.has()) { + if (auto type{TypeAndShape::Characterize(symbol, context)}) { FunctionResult result{std::move(*type)}; CopyAttrs(symbol, result, { diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -296,27 +296,31 @@ CHECK(dimension >= 0); const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())}; if (const auto *details{symbol.detailsIf()}) { - if (IsImpliedShape(symbol)) { - Shape shape{GetShape(symbol).value()}; - return std::move(shape.at(dimension)); - } - int j{0}; - for (const auto &shapeSpec : details->shape()) { - if (j++ == dimension) { - if (shapeSpec.ubound().isExplicit()) { - if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) { - if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) { - return common::Clone(ubound.value()) - - common::Clone(lbound.value()) + ExtentExpr{1}; - } else { - return ubound.value(); + if (IsImpliedShape(symbol) && details->init()) { + if (auto shape{GetShape(symbol)}) { + if (dimension < static_cast(shape->size())) { + return std::move(shape->at(dimension)); + } + } + } else { + int j{0}; + for (const auto &shapeSpec : details->shape()) { + if (j++ == dimension) { + if (shapeSpec.ubound().isExplicit()) { + if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) { + if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) { + return common::Clone(ubound.value()) - + common::Clone(lbound.value()) + ExtentExpr{1}; + } else { + return ubound.value(); + } } + } else if (details->IsAssumedSize() && j == symbol.Rank()) { + return std::nullopt; + } else if (semantics::IsDescriptor(symbol)) { + return ExtentExpr{DescriptorInquiry{NamedEntity{base}, + DescriptorInquiry::Field::Extent, dimension}}; } - } else if (details->IsAssumedSize() && j == symbol.Rank()) { - return std::nullopt; - } else if (semantics::IsDescriptor(symbol)) { - return ExtentExpr{DescriptorInquiry{ - NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}}; } } } @@ -449,7 +453,7 @@ return std::visit( common::visitors{ [&](const semantics::ObjectEntityDetails &object) { - if (IsImpliedShape(symbol)) { + if (IsImpliedShape(symbol) && object.init()) { return (*this)(object.init()); } else { int n{object.shape().Rank()}; diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp --- a/flang/lib/Evaluate/variable.cpp +++ b/flang/lib/Evaluate/variable.cpp @@ -14,6 +14,7 @@ #include "flang/Parser/char-block.h" #include "flang/Parser/characters.h" #include "flang/Parser/message.h" +#include "flang/Semantics/scope.h" #include "flang/Semantics/symbol.h" #include @@ -257,8 +258,13 @@ } // LEN() -static std::optional> SymbolLEN(const Symbol &sym) { - if (auto dyType{DynamicType::From(sym)}) { +static std::optional> SymbolLEN(const Symbol &symbol) { + const Symbol &ultimate{symbol.GetUltimate()}; + if (const auto *assoc{ultimate.detailsIf()}) { + if (const auto *chExpr{UnwrapExpr>(assoc->expr())}) { + return chExpr->LEN(); + } + } else if (auto dyType{DynamicType::From(ultimate)}) { if (const semantics::ParamValue * len{dyType->charLength()}) { if (len->isExplicit()) { if (auto intExpr{len->GetExplicit()}) { @@ -267,8 +273,10 @@ } } } - return Expr{ - DescriptorInquiry{NamedEntity{sym}, DescriptorInquiry::Field::Len}}; + if (IsDescriptor(ultimate) && !ultimate.owner().IsDerivedType()) { + return Expr{DescriptorInquiry{ + NamedEntity{ultimate}, DescriptorInquiry::Field::Len}}; + } } } return std::nullopt; diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -272,6 +272,8 @@ : nullptr}; int actualRank{evaluate::GetRank(actualType.shape())}; bool actualIsPointer{evaluate::IsObjectPointer(actual, context)}; + bool dummyIsAssumedRank{dummy.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedRank)}; if (dummy.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedShape)) { // 15.5.2.4(16) @@ -295,7 +297,8 @@ if (!IsArrayElement(actual) && !(actualType.type().category() == TypeCategory::Character && actualType.type().kind() == 1) && - !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize)) { + !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) && + !dummyIsAssumedRank) { messages.Say( "Whole scalar actual argument may not be associated with a %s array"_err_en_US, dummyName); @@ -355,8 +358,6 @@ bool dummyIsContiguous{ dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}; bool actualIsContiguous{IsSimplyContiguous(actual, context)}; - bool dummyIsAssumedRank{dummy.type.attrs().test( - characteristics::TypeAndShape::Attr::AssumedRank)}; bool dummyIsAssumedShape{dummy.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedShape)}; if ((actualIsAsynchronous || actualIsVolatile) && diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -1847,11 +1847,12 @@ return std::visit( common::visitors{ [&](const characteristics::DummyDataObject &x) { - characteristics::TypeAndShape dummyTypeAndShape{x.type}; - if (!isElemental && actual.Rank() != dummyTypeAndShape.Rank()) { + if (!isElemental && actual.Rank() != x.type.Rank() && + !x.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedRank)) { return false; } else if (auto actualType{actual.GetType()}) { - return dummyTypeAndShape.type().IsTkCompatibleWith(*actualType); + return x.type.type().IsTkCompatibleWith(*actualType); } else { return false; } diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -616,7 +616,7 @@ const std::string &distinctName, const SymbolVector *parameters) { evaluate::StructureConstructorValues values; auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize( - object, context_.foldingContext())}; + symbol, context_.foldingContext())}; CHECK(typeAndShape.has_value()); auto dyType{typeAndShape->type()}; const auto &shape{typeAndShape->shape()};