Index: flang/include/flang/Evaluate/constant.h =================================================================== --- flang/include/flang/Evaluate/constant.h +++ flang/include/flang/Evaluate/constant.h @@ -189,9 +189,7 @@ Constant Reshape(ConstantSubscripts &&) const; llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const; - static constexpr DynamicType GetType() { - return {TypeCategory::Character, KIND}; - } + DynamicType GetType() const { return {KIND, length_}; } std::size_t CopyFrom(const Constant &source, std::size_t count, ConstantSubscripts &resultSubscripts, const std::vector *dimOrder); Index: flang/include/flang/Evaluate/initial-image.h =================================================================== --- flang/include/flang/Evaluate/initial-image.h +++ flang/include/flang/Evaluate/initial-image.h @@ -52,6 +52,7 @@ } else if (bytes == 0) { return Ok; } else { + // TODO endianness std::memcpy(&data_.at(offset), &x.values().at(0), bytes); return Ok; } @@ -80,6 +81,7 @@ (scalarBytes > elementBytes && elements != 0)) { return SizeMismatch; } + // TODO endianness std::memcpy(&data_.at(offset), scalar.data(), elementBytes); offset += elementBytes; } @@ -103,7 +105,7 @@ // Conversions to constant initializers std::optional> AsConstant(FoldingContext &, - const DynamicType &, const ConstantSubscripts &, + const DynamicType &, const ConstantSubscripts &, bool padWithZero = false, ConstantSubscript offset = 0) const; std::optional> AsConstantPointer( ConstantSubscript offset = 0) const; Index: flang/lib/Evaluate/fold-character.cpp =================================================================== --- flang/lib/Evaluate/fold-character.cpp +++ flang/lib/Evaluate/fold-character.cpp @@ -102,7 +102,6 @@ CharacterUtils::TRIM(std::get>(*scalar))}}; } } - // TODO: transfer return Expr{std::move(funcRef)}; } Index: flang/lib/Evaluate/fold-complex.cpp =================================================================== --- flang/lib/Evaluate/fold-complex.cpp +++ flang/lib/Evaluate/fold-complex.cpp @@ -70,7 +70,7 @@ } else if (name == "sum") { return FoldSum(context, std::move(funcRef)); } - // TODO: dot_product, matmul, transfer + // TODO: dot_product, matmul return Expr{std::move(funcRef)}; } Index: flang/lib/Evaluate/fold-implementation.h =================================================================== --- flang/lib/Evaluate/fold-implementation.h +++ flang/lib/Evaluate/fold-implementation.h @@ -70,6 +70,8 @@ Expr TRANSPOSE(FunctionRef &&); Expr UNPACK(FunctionRef &&); + Expr TRANSFER(FunctionRef &&); + private: FoldingContext &context_; }; @@ -1013,6 +1015,17 @@ PackageConstant(std::move(resultElements), *vector, mask->shape())}; } +std::optional> FoldTransfer( + FoldingContext &, const ActualArguments &); + +template Expr Folder::TRANSFER(FunctionRef &&funcRef) { + if (auto folded{FoldTransfer(context_, funcRef.arguments())}) { + return DEREF(UnwrapExpr>(*folded)); + } else { + return Expr{std::move(funcRef)}; + } +} + template Expr FoldMINorMAX( FoldingContext &context, FunctionRef &&funcRef, Ordering order) { @@ -1119,6 +1132,8 @@ return Folder{context}.RESHAPE(std::move(funcRef)); } else if (name == "spread") { return Folder{context}.SPREAD(std::move(funcRef)); + } else if (name == "transfer") { + return Folder{context}.TRANSFER(std::move(funcRef)); } else if (name == "transpose") { return Folder{context}.TRANSPOSE(std::move(funcRef)); } else if (name == "unpack") { Index: flang/lib/Evaluate/fold-integer.cpp =================================================================== --- flang/lib/Evaluate/fold-integer.cpp +++ flang/lib/Evaluate/fold-integer.cpp @@ -1053,7 +1053,7 @@ } else if (name == "ubound") { return UBOUND(context, std::move(funcRef)); } - // TODO: dot_product, ishftc, matmul, sign, transfer + // TODO: dot_product, ishftc, matmul, sign return Expr{std::move(funcRef)}; } Index: flang/lib/Evaluate/fold-logical.cpp =================================================================== --- flang/lib/Evaluate/fold-logical.cpp +++ flang/lib/Evaluate/fold-logical.cpp @@ -199,7 +199,7 @@ } // TODO: dot_product, is_iostat_end, // is_iostat_eor, logical, matmul, out_of_range, - // parity, transfer + // parity return Expr{std::move(funcRef)}; } Index: flang/lib/Evaluate/fold-real.cpp =================================================================== --- flang/lib/Evaluate/fold-real.cpp +++ flang/lib/Evaluate/fold-real.cpp @@ -315,7 +315,7 @@ return result.value; })); } - // TODO: dot_product, fraction, matmul, norm2, set_exponent, transfer + // TODO: dot_product, fraction, matmul, norm2, set_exponent return Expr{std::move(funcRef)}; } Index: flang/lib/Evaluate/fold.cpp =================================================================== --- flang/lib/Evaluate/fold.cpp +++ flang/lib/Evaluate/fold.cpp @@ -9,6 +9,7 @@ #include "flang/Evaluate/fold.h" #include "fold-implementation.h" #include "flang/Evaluate/characteristics.h" +#include "flang/Evaluate/initial-image.h" namespace Fortran::evaluate { @@ -220,6 +221,58 @@ } } +// TRANSFER (F'2018 16.9.193) +std::optional> FoldTransfer( + FoldingContext &context, const ActualArguments &arguments) { + CHECK(arguments.size() == 2 || arguments.size() == 3); + const auto *source{UnwrapExpr>(arguments[0])}; + std::optional sourceBytes; + if (source) { + if (auto sourceTypeAndShape{ + characteristics::TypeAndShape::Characterize(*source, context)}) { + if (auto sourceBytesExpr{ + sourceTypeAndShape->MeasureSizeInBytes(context)}) { + sourceBytes = ToInt64(*sourceBytesExpr); + } + } + } + std::optional moldType; + if (arguments[1]) { + moldType = arguments[1]->GetType(); + } + std::optional extents; + if (arguments.size() == 2) { // no SIZE= + if (moldType && sourceBytes) { + if (arguments[1]->Rank() == 0) { // scalar MOLD= + extents = ConstantSubscripts{}; // empty extents (scalar result) + } else if (auto moldBytesExpr{ + moldType->MeasureSizeInBytes(context, true)}) { + if (auto moldBytes{ToInt64(Fold(context, std::move(*moldBytesExpr)))}; + *moldBytes > 0) { + extents = ConstantSubscripts{ + static_cast((*sourceBytes) + *moldBytes - 1) / + *moldBytes}; + } + } + } + } else if (arguments[2]) { // SIZE= is present + if (const auto *sizeExpr{arguments[2]->UnwrapExpr()}) { + if (auto sizeValue{ToInt64(*sizeExpr)}) { + extents = ConstantSubscripts{*sizeValue}; + } + } + } + if (sourceBytes && IsActuallyConstant(*source) && moldType && extents) { + InitialImage image{*sourceBytes}; + InitialImage::Result imageResult{ + image.Add(0, *sourceBytes, *source, context)}; + CHECK(imageResult == InitialImage::Ok); + return image.AsConstant(context, *moldType, *extents, true /*pad with 0*/); + } else { + return std::nullopt; + } +} + template class ExpressionBase; template class ExpressionBase; Index: flang/lib/Evaluate/initial-image.cpp =================================================================== --- flang/lib/Evaluate/initial-image.cpp +++ flang/lib/Evaluate/initial-image.cpp @@ -72,9 +72,9 @@ using Types = AllTypes; AsConstantHelper(FoldingContext &context, const DynamicType &type, const ConstantSubscripts &extents, const InitialImage &image, - ConstantSubscript offset = 0) + bool padWithZero = false, ConstantSubscript offset = 0) : context_{context}, type_{type}, image_{image}, extents_{extents}, - offset_{offset} { + padWithZero_{padWithZero}, offset_{offset} { CHECK(!type.IsPolymorphic()); } template Result Test() { @@ -94,7 +94,7 @@ ToInt64(type_.MeasureSizeInBytes(context_, GetRank(extents_) > 0))}; CHECK(elemBytes && *elemBytes >= 0); std::size_t stride{static_cast(*elemBytes)}; - CHECK(offset_ + elements * stride <= image_.data_.size()); + CHECK(offset_ + elements * stride <= image_.data_.size() || padWithZero_); if constexpr (T::category == TypeCategory::Derived) { const semantics::DerivedTypeSpec &derived{type_.GetDerivedTypeSpec()}; for (auto iter : DEREF(derived.scope())) { @@ -120,8 +120,8 @@ auto componentExtents{GetConstantExtents(context_, component)}; CHECK(componentExtents.has_value()); for (std::size_t j{0}; j < elements; ++j, at += stride) { - if (Result value{image_.AsConstant( - context_, *componentType, *componentExtents, at)}) { + if (Result value{image_.AsConstant(context_, *componentType, + *componentExtents, padWithZero_, at)}) { typedValue[j].emplace(component, std::move(*value)); } } @@ -134,8 +134,12 @@ 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])}; + auto at{static_cast(offset_ + j * stride)}; + if (at + length > image_.data_.size()) { + CHECK(padWithZero_); + break; + } + const Char *data{reinterpret_cast(&image_.data_[at])}; typedValue[j].assign(data, length); } return AsGenericExpr( @@ -144,8 +148,17 @@ // Lengthless intrinsic type CHECK(sizeof(Scalar) <= stride); for (std::size_t j{0}; j < elements; ++j) { - std::memcpy(&typedValue[j], &image_.data_[offset_ + j * stride], - sizeof(Scalar)); + auto at{static_cast(offset_ + j * stride)}; + std::size_t chunk{sizeof(Scalar)}; + if (at + chunk > image_.data_.size()) { + CHECK(padWithZero_); + if (at >= image_.data_.size()) { + break; + } + chunk = image_.data_.size() - at; + } + // TODO endianness + std::memcpy(&typedValue[j], &image_.data_[at], chunk); } return AsGenericExpr(Const{std::move(typedValue), std::move(extents_)}); } @@ -156,14 +169,15 @@ const DynamicType &type_; const InitialImage &image_; ConstantSubscripts extents_; // a copy + bool padWithZero_; ConstantSubscript offset_; }; std::optional> InitialImage::AsConstant(FoldingContext &context, const DynamicType &type, const ConstantSubscripts &extents, - ConstantSubscript offset) const { + bool padWithZero, ConstantSubscript offset) const { return common::SearchTypes( - AsConstantHelper{context, type, extents, *this, offset}); + AsConstantHelper{context, type, extents, *this, padWithZero, offset}); } std::optional> InitialImage::AsConstantPointer( Index: flang/lib/Semantics/data-to-inits.cpp =================================================================== --- flang/lib/Semantics/data-to-inits.cpp +++ flang/lib/Semantics/data-to-inits.cpp @@ -541,8 +541,8 @@ if (auto dyType{evaluate::DynamicType::From(component)}) { if (auto extents{evaluate::GetConstantExtents( foldingContext, component)}) { - if (auto extant{init.image.AsConstant( - foldingContext, *dyType, *extents, componentOffset)}) { + if (auto extant{init.image.AsConstant(foldingContext, *dyType, + *extents, false /*don't pad*/, componentOffset)}) { initialized = !(*extant == *object->init()); } } Index: flang/test/Evaluate/fold-transfer.f90 =================================================================== --- /dev/null +++ flang/test/Evaluate/fold-transfer.f90 @@ -0,0 +1,37 @@ +! RUN: %python %S/test_folding.py %s %flang_fc1 +! Tests folding of TRANSFER(...) + +module m + logical, parameter :: test_r2i_s_1 = transfer(1., 0) == int(z'3f800000') + logical, parameter :: test_r2i_v_1 = all(transfer(1., [integer::]) == [int(z'3f800000')]) + logical, parameter :: test_r2i_v_2 = all(transfer([1., 2.], [integer::]) == [int(z'3f800000'), int(z'40000000')]) + logical, parameter :: test_r2i_vs_1 = all(transfer([1., 2.], [integer::], 1) == [int(z'3f800000')]) + + type :: t + real :: x = 0. + end type t + logical, parameter :: test_t2i_s_1 = transfer(t(1.), 0) == int(z'3f800000') + logical, parameter :: test_t2i_v_1 = all(transfer(t(1.), [integer::]) == [int(z'3f800000')]) + logical, parameter :: test_t2i_v_2 = all(transfer([t(1.), t(2.)], [integer::]) == [int(z'3f800000'), int(z'40000000')]) + logical, parameter :: test_t2i_vs_1 = all(transfer([t(1.), t(2.)], [integer::], 1) == [int(z'3f800000')]) + + type(t), parameter :: t1 = transfer(1., t()) + logical, parameter :: test_r2t_s_1 = t1%x == 1. + type(t), parameter :: t2(*) = transfer(1., [t::]) + logical, parameter :: test_r2t_v_1 = all(t2%x == [1.]) + type(t), parameter :: t3(*) = transfer([1., 2.], [t::]) + logical, parameter :: test_r2t_v_2 = all(t3%x == [1., 2.]) + type(t), parameter :: t4(*) = transfer([1., 2.], t(), 1) + logical, parameter :: test_r2t_vs_1 = all(t4%x == [1.]) + + logical, parameter :: test_nan = transfer(int(z'7ff8000000000000', 8), 0._8) /= transfer(int(z'7ff8000000000000', 8), 0._8) + + integer, parameter :: jc1 = transfer("abcd", 0) + logical, parameter :: test_c2i_s_1 = jc1 == int(z'61626364') .or. jc1 == int(z'64636261') + integer, parameter :: jc2(*) = transfer("abcd", [integer::]) + logical, parameter :: test_c2i_v_1 = all(jc2 == int(z'61626364') .or. jc1 == int(z'64636261')) + integer, parameter :: jc3(*) = transfer(["abcd", "efgh"], [integer::]) + logical, parameter :: test_c2i_v_2 = all(jc3 == [int(z'61626364'), int(z'65666768')]) .or. all(jc3 == [int(z'64636261'), int(z'68676665')]) + integer, parameter :: jc4(*) = transfer(["abcd", "efgh"], 0, 1) + logical, parameter :: test_c2i_vs_1 = all(jc4 == [int(z'61626364')]) .or. all(jc4 == [int(z'64636261')]) +end module Index: flang/test/Evaluate/folding10.f90 =================================================================== --- flang/test/Evaluate/folding10.f90 +++ flang/test/Evaluate/folding10.f90 @@ -1,7 +1,19 @@ ! RUN: %python %S/test_folding.py %s %flang_fc1 ! Tests folding of SHAPE(TRANSFER(...)) +! Adjusted to allow for folding (or not) of TRANSFER(). module m + integer :: j + real :: a(3) + logical, parameter :: test_size_v1 = size(shape(transfer(j, 0_1,size=4))) == 1 + logical, parameter :: test_size_v2 = all(shape(transfer(j, 0_1,size=4)) == [4]) + logical, parameter :: test_scalar_v1 = size(shape(transfer(j, 0_1))) == 0 + logical, parameter :: test_vector_v1 = size(shape(transfer(j, [0_1]))) == 1 + logical, parameter :: test_vector_v2 = all(shape(transfer(j, [0_1])) == [4]) + logical, parameter :: test_array_v1 = size(shape(transfer(j, reshape([0_1],[1,1])))) == 1 + logical, parameter :: test_array_v2 = all(shape(transfer(j, reshape([0_1],[1,1]))) == [4]) + logical, parameter :: test_array_v3 = all(shape(transfer(a, [(0.,0.)])) == [2]) + 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 Index: flang/test/Semantics/array-constr-values.f90 =================================================================== --- flang/test/Semantics/array-constr-values.f90 +++ flang/test/Semantics/array-constr-values.f90 @@ -29,7 +29,7 @@ ! C7111 !ERROR: Value in array constructor of type 'LOGICAL(4)' could not be converted to the type of the array 'INTEGER(4)' intarray = [integer:: .true., 2, 3, 4, 5] - !ERROR: Value in array constructor of type 'CHARACTER(1)' could not be converted to the type of the array 'INTEGER(4)' + !ERROR: Value in array constructor of type 'CHARACTER(KIND=1,LEN=22_8)' could not be converted to the type of the array 'INTEGER(4)' intarray = [integer:: "RAM stores information", 2, 3, 4, 5] !ERROR: Value in array constructor of type 'employee' could not be converted to the type of the array 'INTEGER(4)' intarray = [integer:: EMPLOYEE (19, "Jack"), 2, 3, 4, 5] Index: flang/test/Semantics/case01.f90 =================================================================== --- flang/test/Semantics/case01.f90 +++ flang/test/Semantics/case01.f90 @@ -69,7 +69,7 @@ ! C1147 select case (grade2) - !ERROR: CASE value has type 'CHARACTER(1)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' + !ERROR: CASE value has type 'CHARACTER(KIND=1,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' case (:'Z') case default end select @@ -94,19 +94,19 @@ case (.true. :) !ERROR: CASE value has type 'REAL(4)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' case (1.0) - !ERROR: CASE value has type 'CHARACTER(1)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' + !ERROR: CASE value has type 'CHARACTER(KIND=1,LEN=3_8)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' case ('wow') end select select case (ASCII_parm1) case (ASCII_parm2) - !ERROR: CASE value has type 'CHARACTER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)' + !ERROR: CASE value has type 'CHARACTER(KIND=4,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)' case (UCS32_parm) - !ERROR: CASE value has type 'CHARACTER(2)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)' + !ERROR: CASE value has type 'CHARACTER(KIND=2,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)' case (UCS16_parm) - !ERROR: CASE value has type 'CHARACTER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)' + !ERROR: CASE value has type 'CHARACTER(KIND=4,LEN=6_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)' case (4_"ucs-32") - !ERROR: CASE value has type 'CHARACTER(2)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)' + !ERROR: CASE value has type 'CHARACTER(KIND=2,LEN=6_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)' case (2_"ucs-16") case default end select Index: flang/test/Semantics/select-rank.f90 =================================================================== --- flang/test/Semantics/select-rank.f90 +++ flang/test/Semantics/select-rank.f90 @@ -239,7 +239,7 @@ RANK(1.0) !ERROR: Must be a constant value RANK(RANK(x)) - !ERROR: Must have INTEGER type, but is CHARACTER(1) + !ERROR: Must have INTEGER type, but is CHARACTER(KIND=1,LEN=6_8) RANK("STRING") END SELECT end subroutine Index: flang/test/Semantics/structconst02.f90 =================================================================== --- flang/test/Semantics/structconst02.f90 +++ flang/test/Semantics/structconst02.f90 @@ -36,7 +36,7 @@ ! call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true._4)) call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true.)) call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true.)) - !ERROR: Value in structure constructor of type 'CHARACTER(1)' is incompatible with component 'ix' of type 'INTEGER(4)' + !ERROR: Value in structure constructor of type 'CHARACTER(KIND=1,LEN=1_8)' is incompatible with component 'ix' of type 'INTEGER(4)' call scalararg(scalar(4)(ix='a')) !ERROR: Value in structure constructor of type 'LOGICAL(4)' is incompatible with component 'ix' of type 'INTEGER(4)' call scalararg(scalar(4)(ix=.false.))