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,6 +78,7 @@ bool operator==(const TypeAndShape &) const; bool operator!=(const TypeAndShape &that) const { return !(*this == that); } + static std::optional Characterize( const semantics::Symbol &, FoldingContext &); static std::optional Characterize( @@ -90,6 +91,8 @@ const semantics::ProcInterface &); static std::optional Characterize( const semantics::DeclTypeSpec &); + static std::optional Characterize( + const ActualArgument &, FoldingContext &); template static std::optional Characterize( @@ -114,6 +117,24 @@ } return std::nullopt; } + template + static std::optional Characterize( + const std::optional &x, FoldingContext &context) { + if (x) { + return Characterize(*x, context); + } else { + return std::nullopt; + } + } + template + static std::optional Characterize( + const A *x, FoldingContext &context) { + if (x) { + return Characterize(*x, context); + } else { + return std::nullopt; + } + } DynamicType type() const { return type_; } TypeAndShape &set_type(DynamicType t) { diff --git a/flang/include/flang/Evaluate/initial-image.h b/flang/include/flang/Evaluate/initial-image.h --- a/flang/include/flang/Evaluate/initial-image.h +++ b/flang/include/flang/Evaluate/initial-image.h @@ -42,8 +42,10 @@ if (offset < 0 || offset + bytes > data_.size()) { return OutOfRange; } else { - auto elementBytes{x.GetType().MeasureSizeInBytes()}; - if (!elementBytes || bytes != x.values().size() * *elementBytes) { + auto elementBytes{ToInt64(x.GetType().MeasureSizeInBytes())}; + if (!elementBytes || + bytes != + x.values().size() * static_cast(*elementBytes)) { return SizeMismatch; } else { std::memcpy(&data_.at(offset), &x.values().at(0), bytes); diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -138,8 +138,9 @@ constexpr const semantics::ParamValue *charLength() const { return charLength_; } - std::optional GetCharLength() const; - std::optional MeasureSizeInBytes() const; + std::optional> GetCharLength() const; + std::optional> MeasureSizeInBytes( + FoldingContext * = nullptr) const; std::string AsFortran() const; std::string AsFortran(std::string &&charLenExpr) const; 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 @@ -121,6 +121,11 @@ } } +std::optional TypeAndShape::Characterize( + const ActualArgument &arg, FoldingContext &context) { + return Characterize(arg.UnwrapExpr(), context); +} + bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages, const TypeAndShape &that, const char *thisIs, const char *thatIs, bool isElemental) const { @@ -183,7 +188,7 @@ o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""); attrs_.Dump(o, EnumToString); if (!shape_.empty()) { - o << " dimension("; + o << " dimension"; char sep{'('}; for (const auto &expr : shape_) { o << sep; diff --git a/flang/lib/Evaluate/fold-designator.cpp b/flang/lib/Evaluate/fold-designator.cpp --- a/flang/lib/Evaluate/fold-designator.cpp +++ b/flang/lib/Evaluate/fold-designator.cpp @@ -27,10 +27,10 @@ } else if (symbol.has() && !IsNamedConstant(symbol)) { if (auto type{DynamicType::From(symbol)}) { - if (auto bytes{type->MeasureSizeInBytes()}) { + if (auto bytes{ToInt64(type->MeasureSizeInBytes(&context_))}) { if (auto extents{GetConstantExtents(context_, symbol)}) { - OffsetSymbol result{symbol, *bytes}; - auto stride{static_cast(*bytes)}; + OffsetSymbol result{symbol, static_cast(*bytes)}; + auto stride{*bytes}; for (auto extent : *extents) { if (extent == 0) { return std::nullopt; @@ -57,7 +57,7 @@ const ArrayRef &x, ConstantSubscript which) { const Symbol &array{x.base().GetLastSymbol()}; if (auto type{DynamicType::From(array)}) { - if (auto bytes{type->MeasureSizeInBytes()}) { + if (auto bytes{ToInt64(type->MeasureSizeInBytes(&context_))}) { if (auto extents{GetConstantExtents(context_, array)}) { Shape lbs{GetLowerBounds(context_, x.base())}; if (auto lowerBounds{AsConstantExtents(context_, lbs)}) { @@ -73,7 +73,7 @@ if (!result) { return std::nullopt; } - auto stride{static_cast(*bytes)}; + auto stride{*bytes}; int dim{0}; for (const Subscript &subscript : x.subscript()) { ConstantSubscript lower{lowerBounds->at(dim)}; @@ -217,14 +217,14 @@ auto extents{AsConstantExtents(context, shape)}; Shape lbs{GetLowerBounds(context, entity)}; auto lower{AsConstantExtents(context, lbs)}; - auto elementBytes{elementType.MeasureSizeInBytes()}; + auto elementBytes{ToInt64(elementType.MeasureSizeInBytes(&context))}; if (!extents || !lower || !elementBytes || *elementBytes <= 0) { return std::nullopt; } int rank{GetRank(shape)}; CHECK(extents->size() == static_cast(rank) && lower->size() == extents->size()); - auto element{offset / *elementBytes}; + auto element{offset / static_cast(*elementBytes)}; std::vector subscripts; auto at{element}; for (int dim{0}; dim + 1 < rank; ++dim) { @@ -239,7 +239,7 @@ } // This final subscript might be out of range for use in error reporting. subscripts.emplace_back(ExtentExpr{(*lower)[rank - 1] + at}); - offset -= element * *elementBytes; + offset -= element * static_cast(*elementBytes); return ArrayRef{std::move(entity), std::move(subscripts)}; } @@ -315,12 +315,12 @@ if (std::optional> result{ TypedWrapper(*type, std::move(*dataRef))}) { if (IsAllocatableOrPointer(symbol)) { - } else if (auto elementBytes{type->MeasureSizeInBytes()}) { + } else if (auto elementBytes{ + ToInt64(type->MeasureSizeInBytes(&context))}) { if (auto *zExpr{std::get_if>(&result->u)}) { - if (size * 2 > *elementBytes) { + if (size * 2 > static_cast(*elementBytes)) { return result; - } else if (offset == 0 || - offset * 2 == static_cast(*elementBytes)) { + } else if (offset == 0 || offset * 2 == *elementBytes) { // Pick a COMPLEX component auto part{ offset == 0 ? ComplexPart::Part::RE : ComplexPart::Part::IM}; @@ -334,7 +334,7 @@ } } else if (auto *cExpr{ std::get_if>(&result->u)}) { - if (offset > 0 || size != *elementBytes) { + if (offset > 0 || size != static_cast(*elementBytes)) { // Select a substring return std::visit( [&](const auto &x) -> std::optional> { diff --git a/flang/lib/Evaluate/initial-image.cpp b/flang/lib/Evaluate/initial-image.cpp --- a/flang/lib/Evaluate/initial-image.cpp +++ b/flang/lib/Evaluate/initial-image.cpp @@ -88,9 +88,10 @@ using Scalar = typename Const::Element; std::size_t elements{TotalElementCount(extents_)}; std::vector typedValue(elements); - auto stride{type_.MeasureSizeInBytes()}; - CHECK(stride > 0); - CHECK(offset_ + elements * *stride <= image_.data_.size()); + auto elemBytes{ToInt64(type_.MeasureSizeInBytes(&context_))}; + CHECK(elemBytes && *elemBytes >= 0); + std::size_t stride{static_cast(*elemBytes)}; + CHECK(offset_ + elements * stride <= image_.data_.size()); if constexpr (T::category == TypeCategory::Derived) { const semantics::DerivedTypeSpec &derived{type_.GetDerivedTypeSpec()}; for (auto iter : DEREF(derived.scope())) { @@ -102,7 +103,7 @@ CHECK(componentType); auto at{offset_ + component.offset()}; if (isPointer) { - for (std::size_t j{0}; j < elements; ++j, at += *stride) { + for (std::size_t j{0}; j < elements; ++j, at += stride) { Result value{image_.AsConstantDataPointer(*componentType, at)}; CHECK(value); typedValue[j].emplace(component, std::move(*value)); @@ -110,7 +111,7 @@ } else { auto componentExtents{GetConstantExtents(context_, component)}; CHECK(componentExtents); - for (std::size_t j{0}; j < elements; ++j, at += *stride) { + for (std::size_t j{0}; j < elements; ++j, at += stride) { Result value{image_.AsConstant( context_, *componentType, *componentExtents, at)}; CHECK(value); @@ -122,20 +123,20 @@ return AsGenericExpr( Const{derived, std::move(typedValue), std::move(extents_)}); } else if constexpr (T::category == TypeCategory::Character) { - auto length{static_cast(*stride) / T::kind}; + auto length{static_cast(stride) / T::kind}; for (std::size_t j{0}; j < elements; ++j) { using Char = typename Scalar::value_type; const Char *data{reinterpret_cast( - &image_.data_[offset_ + j * *stride])}; + &image_.data_[offset_ + j * stride])}; typedValue[j].assign(data, length); } return AsGenericExpr( Const{length, std::move(typedValue), std::move(extents_)}); } else { // Lengthless intrinsic type - CHECK(sizeof(Scalar) <= *stride); + CHECK(sizeof(Scalar) <= stride); for (std::size_t j{0}; j < elements; ++j) { - std::memcpy(&typedValue[j], &image_.data_[offset_ + j * *stride], + std::memcpy(&typedValue[j], &image_.data_[offset_ + j * stride], sizeof(Scalar)); } return AsGenericExpr(Const{std::move(typedValue), std::move(extents_)}); 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 @@ -626,6 +626,43 @@ } } } + } else if (intrinsic->name == "transfer") { + if (call.arguments().size() == 3 && call.arguments().at(2)) { + // SIZE= is present; shape is vector [SIZE=] + if (const auto *size{ + UnwrapExpr>(call.arguments().at(2))}) { + return Shape{ + MaybeExtentExpr{ConvertToType(common::Clone(*size))}}; + } + } else if (auto moldTypeAndShape{ + characteristics::TypeAndShape::Characterize( + call.arguments().at(1), context_)}) { + if (GetRank(moldTypeAndShape->shape()) == 0) { + // SIZE= is absent and MOLD= is scalar: result is scalar + return Scalar(); + } else { + // SIZE= is absent and MOLD= is array: result is vector whose + // length is determined by sizes of types. See 16.9.193p4 case(ii). + if (auto sourceTypeAndShape{ + characteristics::TypeAndShape::Characterize( + call.arguments().at(0), context_)}) { + auto sourceElements{ + GetSize(common::Clone(sourceTypeAndShape->shape()))}; + auto sourceElementBytes{ + sourceTypeAndShape->type().MeasureSizeInBytes(&context_)}; + auto moldElementBytes{ + moldTypeAndShape->type().MeasureSizeInBytes(&context_)}; + if (sourceElements && sourceElementBytes && moldElementBytes) { + ExtentExpr extent{Fold(context_, + ((std::move(*sourceElements) * + std::move(*sourceElementBytes)) + + common::Clone(*moldElementBytes) - ExtentExpr{1}) / + common::Clone(*moldElementBytes))}; + return Shape{MaybeExtentExpr{std::move(extent)}}; + } + } + } + } } else if (intrinsic->name == "transpose") { if (call.arguments().size() >= 1) { if (auto shape{(*this)(call.arguments().at(0))}) { diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -103,11 +103,10 @@ PointeeComparison(derived_, that.derived_); } -std::optional DynamicType::GetCharLength() const { - if (category_ == TypeCategory::Character && charLength_ && - charLength_->isExplicit()) { - if (const auto &len{charLength_->GetExplicit()}) { - return ToInt64(len); +std::optional> DynamicType::GetCharLength() const { + if (category_ == TypeCategory::Character && charLength_) { + if (auto length{charLength_->GetExplicit()}) { + return ConvertToType(std::move(*length)); } } return std::nullopt; @@ -125,24 +124,31 @@ } } -std::optional DynamicType::MeasureSizeInBytes() const { +std::optional> DynamicType::MeasureSizeInBytes( + FoldingContext *context) const { switch (category_) { case TypeCategory::Integer: - return kind_; + return Expr{kind_}; case TypeCategory::Real: - return RealKindBytes(kind_); + return Expr{RealKindBytes(kind_)}; case TypeCategory::Complex: - return 2 * RealKindBytes(kind_); + return Expr{2 * RealKindBytes(kind_)}; case TypeCategory::Character: if (auto len{GetCharLength()}) { - return kind_ * *len; + auto result{Expr{kind_} * std::move(*len)}; + if (context) { + return Fold(*context, std::move(result)); + } else { + return std::move(result); + } } break; case TypeCategory::Logical: - return kind_; + return Expr{kind_}; case TypeCategory::Derived: if (derived_ && derived_->scope()) { - return derived_->scope()->size(); + return Expr{ + static_cast(derived_->scope()->size())}; } break; } diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp --- a/flang/lib/Semantics/compute-offsets.cpp +++ b/flang/lib/Semantics/compute-offsets.cpp @@ -396,13 +396,14 @@ if (category == TypeCategory::Character) { return {static_cast(kind)}; } - std::optional size{ - evaluate::DynamicType{category, kind}.MeasureSizeInBytes()}; - CHECK(size.has_value()); + auto bytes{evaluate::ToInt64( + evaluate::DynamicType{category, kind}.MeasureSizeInBytes())}; + CHECK(bytes && *bytes > 0); + std::size_t size{static_cast(*bytes)}; if (category == TypeCategory::Complex) { - return {*size, *size >> 1}; + return {size, size >> 1}; } else { - return {*size}; + return {size}; } } diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp --- a/flang/lib/Semantics/data-to-inits.cpp +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -229,7 +229,9 @@ // (most) other Fortran compilers do. Pad on the right with spaces // when short, truncate the right if long. // TODO: big-endian targets - std::size_t bytes{type.MeasureSizeInBytes().value()}; + std::size_t bytes{static_cast(evaluate::ToInt64( + type.MeasureSizeInBytes(&exprAnalyzer_.GetFoldingContext())) + .value())}; evaluate::BOZLiteralConstant bits{0}; for (std::size_t j{0}; j < bytes; ++j) { char ch{j >= chValue->size() ? ' ' : chValue->at(j)}; @@ -425,12 +427,16 @@ } // Compute the minimum common granularity if (auto dyType{evaluate::DynamicType::From(symbol)}) { - minElementBytes = dyType->MeasureSizeInBytes().value_or(1); + minElementBytes = evaluate::ToInt64( + dyType->MeasureSizeInBytes(&exprAnalyzer.GetFoldingContext())) + .value_or(1); } for (const Symbol *s : conflicts) { if (auto dyType{evaluate::DynamicType::From(*s)}) { - minElementBytes = - std::min(minElementBytes, dyType->MeasureSizeInBytes().value_or(1)); + minElementBytes = std::min(minElementBytes, + static_cast(evaluate::ToInt64( + dyType->MeasureSizeInBytes(&exprAnalyzer.GetFoldingContext())) + .value_or(1))); } else { minElementBytes = 1; } diff --git a/flang/test/Evaluate/folding10.f90 b/flang/test/Evaluate/folding10.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Evaluate/folding10.f90 @@ -0,0 +1,13 @@ +! RUN: %S/test_folding.sh %s %t %f18 +! Tests folding of SHAPE(TRANSFER(...)) + +module m + logical, parameter :: test_size_1 = size(shape(transfer(123456789,0_1,size=4))) == 1 + logical, parameter :: test_size_2 = all(shape(transfer(123456789,0_1,size=4)) == [4]) + logical, parameter :: test_scalar_1 = size(shape(transfer(123456789, 0_1))) == 0 + logical, parameter :: test_vector_1 = size(shape(transfer(123456789, [0_1]))) == 1 + logical, parameter :: test_vector_2 = all(shape(transfer(123456789, [0_1])) == [4]) + logical, parameter :: test_array_1 = size(shape(transfer(123456789, reshape([0_1],[1,1])))) == 1 + logical, parameter :: test_array_2 = all(shape(transfer(123456789, reshape([0_1],[1,1]))) == [4]) + logical, parameter :: test_array_3 = all(shape(transfer([1.,2.,3.], [(0.,0.)])) == [2]) +end module