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 @@ -186,9 +186,14 @@ // 7.3.2.3 & 15.5.2.4 type compatibility. // x.IsTkCompatibleWith(y) is true if "x => y" or passing actual y to // dummy argument x would be valid. Be advised, this is not a reflexive - // relation. Kind type parameters must match. + // relation. Kind type parameters must match, but CHARACTER lengths + // need not do so. bool IsTkCompatibleWith(const DynamicType &) const; + // A stronger compatibility check that does not allow distinct known + // values for CHARACTER lengths for e.g. MOVE_ALLOC(). + bool IsTkLenCompatibleWith(const DynamicType &) const; + // EXTENDS_TYPE_OF (16.9.76); ignores type parameter values std::optional ExtendsTypeOf(const DynamicType &) const; // SAME_TYPE_AS (16.9.165); ignores type parameter values diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -82,8 +82,8 @@ // match any kind, but all "same" kinds must be equal. For characters, also // implies that lengths must be equal. same, - // for character results, take "same" argument kind but not length - sameKindButNotLength, + // for characters that only require the same kind, not length + sameKind, operand, // match any kind, with promotion (non-standard) typeless, // BOZ literals are INTEGER with this kind teamType, // TEAM_TYPE from module ISO_FORTRAN_ENV (for coarrays) @@ -157,8 +157,7 @@ static constexpr TypePattern SameFloating{FloatingType, KindCode::same}; static constexpr TypePattern SameNumeric{NumericType, KindCode::same}; static constexpr TypePattern SameChar{CharType, KindCode::same}; -static constexpr TypePattern SameCharNewLen{ - CharType, KindCode::sameKindButNotLength}; +static constexpr TypePattern SameCharNoLen{CharType, KindCode::sameKind}; static constexpr TypePattern SameLogical{LogicalType, KindCode::same}; static constexpr TypePattern SameRelatable{RelatableType, KindCode::same}; static constexpr TypePattern SameIntrinsic{IntrinsicType, KindCode::same}; @@ -471,13 +470,15 @@ {"back", AnyLogical, Rank::scalar, Optionality::optional}}, KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, {"findloc", - {{"array", SameChar, Rank::array}, {"value", SameChar, Rank::scalar}, - RequiredDIM, OptionalMASK, SizeDefaultKIND, + {{"array", SameCharNoLen, Rank::array}, + {"value", SameCharNoLen, Rank::scalar}, RequiredDIM, OptionalMASK, + SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, KINDInt, Rank::locReduced, IntrinsicClass::transformationalFunction}, {"findloc", - {{"array", SameChar, Rank::array}, {"value", SameChar, Rank::scalar}, - MissingDIM, OptionalMASK, SizeDefaultKIND, + {{"array", SameCharNoLen, Rank::array}, + {"value", SameCharNoLen, Rank::scalar}, MissingDIM, OptionalMASK, + SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, {"findloc", @@ -525,7 +526,7 @@ {"ieor", {{"i", BOZ}, {"j", SameInt}}, SameInt}, {"image_status", {{"image", SameInt}, OptionalTEAM}, DefaultInt}, {"index", - {{"string", SameChar}, {"substring", SameChar}, + {{"string", SameCharNoLen}, {"substring", SameCharNoLen}, {"back", AnyLogical, Rank::elemental, Optionality::optional}, DefaultingKIND}, KINDInt}, @@ -565,10 +566,14 @@ DefaultingKIND}, KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"len_trim", {{"string", AnyChar}, DefaultingKIND}, KINDInt}, - {"lge", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, - {"lgt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, - {"lle", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, - {"llt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, + {"lge", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}}, + DefaultLogical}, + {"lgt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}}, + DefaultLogical}, + {"lle", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}}, + DefaultLogical}, + {"llt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}}, + DefaultLogical}, {"loc", {{"loc_argument", Addressable, Rank::anyOrAssumedRank}}, SubscriptInt, Rank::scalar}, {"log", {{"x", SameFloating}}, SameFloating}, @@ -606,9 +611,9 @@ {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}}, OperandIntOrReal}, {"max", - {{"a1", SameChar}, {"a2", SameChar}, - {"a3", SameChar, Rank::elemental, Optionality::repeats}}, - SameChar}, + {{"a1", SameCharNoLen}, {"a2", SameCharNoLen}, + {"a3", SameCharNoLen, Rank::elemental, Optionality::repeats}}, + SameCharNoLen}, {"maxexponent", {{"x", AnyReal, Rank::anyOrAssumedRank, Optionality::required, common::Intent::In, {ArgFlag::canBeNull}}}, @@ -645,9 +650,9 @@ {"a3", OperandIntOrReal, Rank::elemental, Optionality::repeats}}, OperandIntOrReal}, {"min", - {{"a1", SameChar}, {"a2", SameChar}, - {"a3", SameChar, Rank::elemental, Optionality::repeats}}, - SameChar}, + {{"a1", SameCharNoLen}, {"a2", SameCharNoLen}, + {"a3", SameCharNoLen, Rank::elemental, Optionality::repeats}}, + SameCharNoLen}, {"minexponent", {{"x", AnyReal, Rank::anyOrAssumedRank, Optionality::required, common::Intent::In, {ArgFlag::canBeNull}}}, @@ -675,9 +680,9 @@ OperandIntOrReal}, {"nearest", {{"x", SameReal}, {"s", AnyReal}}, SameReal}, {"new_line", - {{"a", SameChar, Rank::anyOrAssumedRank, Optionality::required, + {{"a", SameCharNoLen, Rank::anyOrAssumedRank, Optionality::required, common::Intent::In, {ArgFlag::canBeNull}}}, - SameChar, Rank::scalar, IntrinsicClass::inquiryFunction}, + SameCharNoLen, Rank::scalar, IntrinsicClass::inquiryFunction}, {"nint", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, {"norm2", {{"x", SameReal, Rank::array}, OptionalDIM}, SameReal, Rank::dimReduced, IntrinsicClass::transformationalFunction}, @@ -748,8 +753,8 @@ {"identity", SameType, Rank::scalar, Optionality::optional}, {"ordered", AnyLogical, Rank::scalar, Optionality::optional}}, SameType, Rank::scalar, IntrinsicClass::transformationalFunction}, - {"repeat", {{"string", SameChar, Rank::scalar}, {"ncopies", AnyInt}}, - SameCharNewLen, Rank::scalar, IntrinsicClass::transformationalFunction}, + {"repeat", {{"string", SameCharNoLen, Rank::scalar}, {"ncopies", AnyInt}}, + SameCharNoLen, Rank::scalar, IntrinsicClass::transformationalFunction}, {"reshape", {{"source", SameType, Rank::array}, {"shape", AnyInt, Rank::shape}, {"pad", SameType, Rank::array, Optionality::optional}, @@ -762,7 +767,7 @@ DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, {"scale", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, // == IEEE_SCALB() {"scan", - {{"string", SameChar}, {"set", SameChar}, + {{"string", SameCharNoLen}, {"set", SameCharNoLen}, {"back", AnyLogical, Rank::elemental, Optionality::optional}, DefaultingKIND}, KINDInt}, @@ -851,8 +856,8 @@ SameType, Rank::vector, IntrinsicClass::transformationalFunction}, {"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix, IntrinsicClass::transformationalFunction}, - {"trim", {{"string", SameChar, Rank::scalar}}, SameCharNewLen, Rank::scalar, - IntrinsicClass::transformationalFunction}, + {"trim", {{"string", SameCharNoLen, Rank::scalar}}, SameCharNoLen, + Rank::scalar, IntrinsicClass::transformationalFunction}, {"ubound", {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM, SizeDefaultKIND}, @@ -867,7 +872,7 @@ {"field", SameType, Rank::conformable}}, SameType, Rank::conformable, IntrinsicClass::transformationalFunction}, {"verify", - {{"string", SameChar}, {"set", SameChar}, + {{"string", SameCharNoLen}, {"set", SameCharNoLen}, {"back", AnyLogical, Rank::elemental, Optionality::optional}, DefaultingKIND}, KINDInt}, @@ -1687,6 +1692,12 @@ argOk = true; break; case KindCode::same: + if (!sameArg) { + sameArg = arg; + } + argOk = type->IsTkLenCompatibleWith(sameArg->GetType().value()); + break; + case KindCode::sameKind: if (!sameArg) { sameArg = arg; } @@ -1958,7 +1969,7 @@ } } break; - case KindCode::sameKindButNotLength: + case KindCode::sameKind: CHECK(sameArg); if (std::optional aType{sameArg->GetType()}) { resultType = DynamicType{*category, aType->kind()}; @@ -2868,7 +2879,7 @@ context.messages().Say(at, "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US); } else if (result->type().IsPolymorphic() || - !arrayType->IsTkCompatibleWith(result->type())) { + !arrayType->IsTkLenCompatibleWith(result->type())) { ok = false; context.messages().Say(at, "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US); 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 @@ -318,13 +318,18 @@ } static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y, - bool ignoreTypeParameterValues) { + bool ignoreTypeParameterValues, bool ignoreLengths) { if (x.IsUnlimitedPolymorphic()) { return true; } else if (y.IsUnlimitedPolymorphic()) { return false; } else if (x.category() != y.category()) { return false; + } else if (x.category() == TypeCategory::Character) { + const auto xLen{x.knownLength()}; + const auto yLen{y.knownLength()}; + return x.kind() == y.kind() && + (ignoreLengths || !xLen || !yLen || *xLen == *yLen); } else if (x.category() != TypeCategory::Derived) { return x.kind() == y.kind(); } else { @@ -338,13 +343,17 @@ // See 7.3.2.3 (5) & 15.5.2.4 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const { - return AreCompatibleTypes(*this, that, false); + return AreCompatibleTypes(*this, that, false, true); +} + +bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const { + return AreCompatibleTypes(*this, that, false, false); } // 16.9.165 std::optional DynamicType::SameTypeAs(const DynamicType &that) const { - bool x{AreCompatibleTypes(*this, that, true)}; - bool y{AreCompatibleTypes(that, *this, true)}; + bool x{AreCompatibleTypes(*this, that, true, true)}; + bool y{AreCompatibleTypes(that, *this, true, true)}; if (x == y) { return x; } else { diff --git a/flang/test/Evaluate/folding23.f90 b/flang/test/Evaluate/folding23.f90 --- a/flang/test/Evaluate/folding23.f90 +++ b/flang/test/Evaluate/folding23.f90 @@ -7,7 +7,7 @@ logical, parameter :: test_eoshift_1 = all(eoshift([1, 2, 3], 1) == [2, 3, 0]) logical, parameter :: test_eoshift_2 = all(eoshift([1, 2, 3], -1) == [0, 1, 2]) logical, parameter :: test_eoshift_3 = all(eoshift([1., 2., 3.], 1) == [2., 3., 0.]) - logical, parameter :: test_eoshift_4 = all(eoshift(['ab', 'cd', 'ef'], -1, 'x') == ['x ', 'ab', 'cd']) + logical, parameter :: test_eoshift_4 = all(eoshift(['ab', 'cd', 'ef'], -1, 'x ') == ['x ', 'ab', 'cd']) logical, parameter :: test_eoshift_5 = all([eoshift(arr, 1, dim=1)] == [2, 0, 4, 0, 6, 0]) logical, parameter :: test_eoshift_6 = all([eoshift(arr, 1, dim=2)] == [3, 4, 5, 6, 0, 0]) logical, parameter :: test_eoshift_7 = all([eoshift(arr, [1, -1, 0])] == [2, 0, 0, 3, 5, 6]) diff --git a/flang/test/Semantics/move_alloc.f90 b/flang/test/Semantics/move_alloc.f90 --- a/flang/test/Semantics/move_alloc.f90 +++ b/flang/test/Semantics/move_alloc.f90 @@ -11,6 +11,7 @@ end type class(t), allocatable :: t1 type(t), allocatable :: t2 + character, allocatable :: ca*2, cb*3 ! standards conforming allocate(a(3)[*]) @@ -63,4 +64,7 @@ call move_alloc(t1, t2) call move_alloc(t2, t1) ! ok + !ERROR: Actual argument for 'to=' has bad type or kind 'CHARACTER(KIND=1,LEN=3_8)' + call move_alloc(ca, cb) + end program main